{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{- |
   Module      : Text.Pandoc.Writers.Powerpoint.Output
   Copyright   : Copyright (C) 2017-2020 Jesse Rosenthal
   License     : GNU GPL, version 2 or above

   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
   Stability   : alpha
   Portability : portable

Conversion of Presentation datatype (defined in
Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive.
-}

module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive
                                             ) where

import Control.Monad.Except (throwError, catchError)
import Control.Monad.Reader
import Control.Monad.State
import Codec.Archive.Zip
import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse)
import Data.Bifunctor (bimap)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Default
import Data.Foldable (toList)
import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|)))
import Data.Ratio ((%), Ratio)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Data.Time (formatTime, defaultTimeLocale)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.Traversable (for)
import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension, takeFileName)
import Text.Pandoc.XML.Light as XML
import Text.Pandoc.Definition
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Error (PandocError(..))
import qualified Text.Pandoc.Class.PandocMonad as P
import Text.Pandoc.Options
import Text.Pandoc.MIME
import qualified Data.ByteString.Lazy as BL
import Text.Pandoc.Writers.Shared (metaToContext)
import Text.Pandoc.Writers.OOXML
import qualified Data.Map as M
import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, maybeToList, catMaybes, isJust)
import Text.Pandoc.ImageSize
import Control.Applicative ((<|>))
import System.FilePath.Glob
import Text.DocTemplates (FromContext(lookupContext), Context)
import Text.DocLayout (literal)
import Text.TeXMath
import Text.Pandoc.Logging (LogMessage(PowerpointTemplateWarning))
import Text.Pandoc.Writers.Math (convertMath)
import Text.Pandoc.Writers.Powerpoint.Presentation
import Text.Pandoc.Shared (tshow, stringify)
import Skylighting (fromColor)

-- |The 'EMU' type is used to specify sizes in English Metric Units.
type EMU = Integer

-- |The 'pixelsToEmu' function converts a size in pixels to one
-- in English Metric Units. It assumes a DPI of 72.
pixelsToEmu :: Pixels -> EMU
pixelsToEmu :: Pixels -> Pixels
pixelsToEmu = (12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
*)

-- This populates the global ids map with images already in the
-- template, so the ids won't be used by images introduced by the
-- user.
initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int
initialGlobalIds :: Archive -> Archive -> Map FilePath Int
initialGlobalIds refArchive :: Archive
refArchive distArchive :: Archive
distArchive =
  let archiveFiles :: [FilePath]
archiveFiles = Archive -> [FilePath]
filesInArchive Archive
refArchive [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
`union` Archive -> [FilePath]
filesInArchive Archive
distArchive
      mediaPaths :: [FilePath]
mediaPaths = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "ppt/media/image") [FilePath]
archiveFiles

      go :: FilePath -> Maybe (FilePath, Int)
      go :: FilePath -> Maybe (FilePath, Int)
go fp :: FilePath
fp = do
        FilePath
s <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "ppt/media/image" (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
fp
        (n :: Int
n, _) <- [(Int, FilePath)] -> Maybe (Int, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Int, FilePath)] -> Maybe (Int, FilePath))
-> [(Int, FilePath)] -> Maybe (Int, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Int
forall a. Read a => ReadS a
reads FilePath
s
        (FilePath, Int) -> Maybe (FilePath, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
fp, Int
n)
  in
    [(FilePath, Int)] -> Map FilePath Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, Int)] -> Map FilePath Int)
-> [(FilePath, Int)] -> Map FilePath Int
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe (FilePath, Int))
-> [FilePath] -> [(FilePath, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe (FilePath, Int)
go [FilePath]
mediaPaths

getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)
getPresentationSize :: Archive -> Archive -> Maybe (Pixels, Pixels)
getPresentationSize refArchive :: Archive
refArchive distArchive :: Archive
distArchive = do
  Entry
entry <- FilePath -> Archive -> Maybe Entry
findEntryByPath "ppt/presentation.xml" Archive
refArchive  Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
           FilePath -> Archive -> Maybe Entry
findEntryByPath "ppt/presentation.xml" Archive
distArchive
  Element
presElement <- (Text -> Maybe Element)
-> (Element -> Maybe Element)
-> Either Text Element
-> Maybe Element
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Element -> Text -> Maybe Element
forall a b. a -> b -> a
const Maybe Element
forall a. Maybe a
Nothing) Element -> Maybe Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Element -> Maybe Element)
-> Either Text Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
                   Text -> Either Text Element
parseXMLElement (Text -> Either Text Element) -> Text -> Either Text Element
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
UTF8.toTextLazy (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
fromEntry Entry
entry
  let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
presElement
  Element
sldSize <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "sldSz") Element
presElement
  Text
cxS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "cx" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
sldSize
  Text
cyS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "cy" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
sldSize
  Pixels
cx <- Text -> Maybe Pixels
readTextAsInteger Text
cxS
  Pixels
cy <- Text -> Maybe Pixels
readTextAsInteger Text
cyS
  (Pixels, Pixels) -> Maybe (Pixels, Pixels)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixels
cx Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
cy Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700)

readTextAsInteger :: Text -> Maybe Integer
readTextAsInteger :: Text -> Maybe Pixels
readTextAsInteger = (FilePath -> Maybe Pixels)
-> ((Pixels, Text) -> Maybe Pixels)
-> Either FilePath (Pixels, Text)
-> Maybe Pixels
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Pixels -> FilePath -> Maybe Pixels
forall a b. a -> b -> a
const Maybe Pixels
forall a. Maybe a
Nothing) (Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just (Pixels -> Maybe Pixels)
-> ((Pixels, Text) -> Pixels) -> (Pixels, Text) -> Maybe Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pixels, Text) -> Pixels
forall a b. (a, b) -> a
fst) (Either FilePath (Pixels, Text) -> Maybe Pixels)
-> (Text -> Either FilePath (Pixels, Text)) -> Text -> Maybe Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either FilePath (Pixels, Text)
forall a. Integral a => Reader a
Data.Text.Read.decimal

data WriterEnv = WriterEnv { WriterEnv -> Archive
envRefArchive :: Archive
                           , WriterEnv -> Archive
envDistArchive :: Archive
                           , WriterEnv -> UTCTime
envUTCTime :: UTCTime
                           , WriterEnv -> WriterOptions
envOpts :: WriterOptions
                           , WriterEnv -> Context Text
envContext :: Context Text
                           , WriterEnv -> (Pixels, Pixels)
envPresentationSize :: (Integer, Integer)
                           , WriterEnv -> Bool
envSlideHasHeader :: Bool
                           , WriterEnv -> Bool
envInList :: Bool
                           , WriterEnv -> Bool
envInNoteSlide :: Bool
                           , WriterEnv -> Int
envCurSlideId :: Int
                           , WriterEnv -> Placeholder
envPlaceholder :: Placeholder
                           , WriterEnv -> Map SlideId Int
envSlideIdMap :: M.Map SlideId Int
                           -- maps the slide number to the
                           -- corresponding notes id number. If there
                           -- are no notes for a slide, there will be
                           -- no entry in the map for it.
                           , WriterEnv -> Map Int Int
envSpeakerNotesIdMap :: M.Map Int Int
                           , WriterEnv -> Bool
envInSpeakerNotes :: Bool
                           , WriterEnv -> Maybe SlideLayouts
envSlideLayouts :: Maybe SlideLayouts
                           , WriterEnv -> Maybe Indents
envOtherStyleIndents :: Maybe Indents
                           }
                 deriving (Int -> WriterEnv -> ShowS
[WriterEnv] -> ShowS
WriterEnv -> FilePath
(Int -> WriterEnv -> ShowS)
-> (WriterEnv -> FilePath)
-> ([WriterEnv] -> ShowS)
-> Show WriterEnv
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [WriterEnv] -> ShowS
$cshowList :: [WriterEnv] -> ShowS
show :: WriterEnv -> FilePath
$cshow :: WriterEnv -> FilePath
showsPrec :: Int -> WriterEnv -> ShowS
$cshowsPrec :: Int -> WriterEnv -> ShowS
Show)

instance Default WriterEnv where
  def :: WriterEnv
def = WriterEnv :: Archive
-> Archive
-> UTCTime
-> WriterOptions
-> Context Text
-> (Pixels, Pixels)
-> Bool
-> Bool
-> Bool
-> Int
-> Placeholder
-> Map SlideId Int
-> Map Int Int
-> Bool
-> Maybe SlideLayouts
-> Maybe Indents
-> WriterEnv
WriterEnv { envRefArchive :: Archive
envRefArchive = Archive
emptyArchive
                  , envDistArchive :: Archive
envDistArchive = Archive
emptyArchive
                  , envUTCTime :: UTCTime
envUTCTime = POSIXTime -> UTCTime
posixSecondsToUTCTime 0
                  , envOpts :: WriterOptions
envOpts = WriterOptions
forall a. Default a => a
def
                  , envContext :: Context Text
envContext = Context Text
forall a. Monoid a => a
mempty
                  , envPresentationSize :: (Pixels, Pixels)
envPresentationSize = (720, 540)
                  , envSlideHasHeader :: Bool
envSlideHasHeader = Bool
False
                  , envInList :: Bool
envInList = Bool
False
                  , envInNoteSlide :: Bool
envInNoteSlide = Bool
False
                  , envCurSlideId :: Int
envCurSlideId = 1
                  , envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 0
                  , envSlideIdMap :: Map SlideId Int
envSlideIdMap = Map SlideId Int
forall a. Monoid a => a
mempty
                  , envSpeakerNotesIdMap :: Map Int Int
envSpeakerNotesIdMap = Map Int Int
forall a. Monoid a => a
mempty
                  , envInSpeakerNotes :: Bool
envInSpeakerNotes = Bool
False
                  , envSlideLayouts :: Maybe SlideLayouts
envSlideLayouts = Maybe SlideLayouts
forall a. Maybe a
Nothing
                  , envOtherStyleIndents :: Maybe Indents
envOtherStyleIndents = Maybe Indents
forall a. Maybe a
Nothing
                  }

type SlideLayouts = SlideLayoutsOf SlideLayout

data SlideLayoutsOf a = SlideLayouts
  { SlideLayoutsOf a -> a
metadata :: a
  , SlideLayoutsOf a -> a
title :: a
  , SlideLayoutsOf a -> a
content :: a
  , SlideLayoutsOf a -> a
twoColumn :: a
  , SlideLayoutsOf a -> a
comparison :: a
  , SlideLayoutsOf a -> a
contentWithCaption :: a
  , SlideLayoutsOf a -> a
blank :: a
  } deriving (Int -> SlideLayoutsOf a -> ShowS
[SlideLayoutsOf a] -> ShowS
SlideLayoutsOf a -> FilePath
(Int -> SlideLayoutsOf a -> ShowS)
-> (SlideLayoutsOf a -> FilePath)
-> ([SlideLayoutsOf a] -> ShowS)
-> Show (SlideLayoutsOf a)
forall a. Show a => Int -> SlideLayoutsOf a -> ShowS
forall a. Show a => [SlideLayoutsOf a] -> ShowS
forall a. Show a => SlideLayoutsOf a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SlideLayoutsOf a] -> ShowS
$cshowList :: forall a. Show a => [SlideLayoutsOf a] -> ShowS
show :: SlideLayoutsOf a -> FilePath
$cshow :: forall a. Show a => SlideLayoutsOf a -> FilePath
showsPrec :: Int -> SlideLayoutsOf a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SlideLayoutsOf a -> ShowS
Show, SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
(SlideLayoutsOf a -> SlideLayoutsOf a -> Bool)
-> (SlideLayoutsOf a -> SlideLayoutsOf a -> Bool)
-> Eq (SlideLayoutsOf a)
forall a. Eq a => SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
$c/= :: forall a. Eq a => SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
== :: SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
$c== :: forall a. Eq a => SlideLayoutsOf a -> SlideLayoutsOf a -> Bool
Eq, a -> SlideLayoutsOf b -> SlideLayoutsOf a
(a -> b) -> SlideLayoutsOf a -> SlideLayoutsOf b
(forall a b. (a -> b) -> SlideLayoutsOf a -> SlideLayoutsOf b)
-> (forall a b. a -> SlideLayoutsOf b -> SlideLayoutsOf a)
-> Functor SlideLayoutsOf
forall a b. a -> SlideLayoutsOf b -> SlideLayoutsOf a
forall a b. (a -> b) -> SlideLayoutsOf a -> SlideLayoutsOf b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SlideLayoutsOf b -> SlideLayoutsOf a
$c<$ :: forall a b. a -> SlideLayoutsOf b -> SlideLayoutsOf a
fmap :: (a -> b) -> SlideLayoutsOf a -> SlideLayoutsOf b
$cfmap :: forall a b. (a -> b) -> SlideLayoutsOf a -> SlideLayoutsOf b
Functor, SlideLayoutsOf a -> Bool
(a -> m) -> SlideLayoutsOf a -> m
(a -> b -> b) -> b -> SlideLayoutsOf a -> b
(forall m. Monoid m => SlideLayoutsOf m -> m)
-> (forall m a. Monoid m => (a -> m) -> SlideLayoutsOf a -> m)
-> (forall m a. Monoid m => (a -> m) -> SlideLayoutsOf a -> m)
-> (forall a b. (a -> b -> b) -> b -> SlideLayoutsOf a -> b)
-> (forall a b. (a -> b -> b) -> b -> SlideLayoutsOf a -> b)
-> (forall b a. (b -> a -> b) -> b -> SlideLayoutsOf a -> b)
-> (forall b a. (b -> a -> b) -> b -> SlideLayoutsOf a -> b)
-> (forall a. (a -> a -> a) -> SlideLayoutsOf a -> a)
-> (forall a. (a -> a -> a) -> SlideLayoutsOf a -> a)
-> (forall a. SlideLayoutsOf a -> [a])
-> (forall a. SlideLayoutsOf a -> Bool)
-> (forall a. SlideLayoutsOf a -> Int)
-> (forall a. Eq a => a -> SlideLayoutsOf a -> Bool)
-> (forall a. Ord a => SlideLayoutsOf a -> a)
-> (forall a. Ord a => SlideLayoutsOf a -> a)
-> (forall a. Num a => SlideLayoutsOf a -> a)
-> (forall a. Num a => SlideLayoutsOf a -> a)
-> Foldable SlideLayoutsOf
forall a. Eq a => a -> SlideLayoutsOf a -> Bool
forall a. Num a => SlideLayoutsOf a -> a
forall a. Ord a => SlideLayoutsOf a -> a
forall m. Monoid m => SlideLayoutsOf m -> m
forall a. SlideLayoutsOf a -> Bool
forall a. SlideLayoutsOf a -> Int
forall a. SlideLayoutsOf a -> [a]
forall a. (a -> a -> a) -> SlideLayoutsOf a -> a
forall m a. Monoid m => (a -> m) -> SlideLayoutsOf a -> m
forall b a. (b -> a -> b) -> b -> SlideLayoutsOf a -> b
forall a b. (a -> b -> b) -> b -> SlideLayoutsOf a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: SlideLayoutsOf a -> a
$cproduct :: forall a. Num a => SlideLayoutsOf a -> a
sum :: SlideLayoutsOf a -> a
$csum :: forall a. Num a => SlideLayoutsOf a -> a
minimum :: SlideLayoutsOf a -> a
$cminimum :: forall a. Ord a => SlideLayoutsOf a -> a
maximum :: SlideLayoutsOf a -> a
$cmaximum :: forall a. Ord a => SlideLayoutsOf a -> a
elem :: a -> SlideLayoutsOf a -> Bool
$celem :: forall a. Eq a => a -> SlideLayoutsOf a -> Bool
length :: SlideLayoutsOf a -> Int
$clength :: forall a. SlideLayoutsOf a -> Int
null :: SlideLayoutsOf a -> Bool
$cnull :: forall a. SlideLayoutsOf a -> Bool
toList :: SlideLayoutsOf a -> [a]
$ctoList :: forall a. SlideLayoutsOf a -> [a]
foldl1 :: (a -> a -> a) -> SlideLayoutsOf a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SlideLayoutsOf a -> a
foldr1 :: (a -> a -> a) -> SlideLayoutsOf a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> SlideLayoutsOf a -> a
foldl' :: (b -> a -> b) -> b -> SlideLayoutsOf a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SlideLayoutsOf a -> b
foldl :: (b -> a -> b) -> b -> SlideLayoutsOf a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SlideLayoutsOf a -> b
foldr' :: (a -> b -> b) -> b -> SlideLayoutsOf a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SlideLayoutsOf a -> b
foldr :: (a -> b -> b) -> b -> SlideLayoutsOf a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> SlideLayoutsOf a -> b
foldMap' :: (a -> m) -> SlideLayoutsOf a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SlideLayoutsOf a -> m
foldMap :: (a -> m) -> SlideLayoutsOf a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SlideLayoutsOf a -> m
fold :: SlideLayoutsOf m -> m
$cfold :: forall m. Monoid m => SlideLayoutsOf m -> m
Foldable, Functor SlideLayoutsOf
Foldable SlideLayoutsOf
(Functor SlideLayoutsOf, Foldable SlideLayoutsOf) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> SlideLayoutsOf a -> f (SlideLayoutsOf b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SlideLayoutsOf (f a) -> f (SlideLayoutsOf a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SlideLayoutsOf a -> m (SlideLayoutsOf b))
-> (forall (m :: * -> *) a.
    Monad m =>
    SlideLayoutsOf (m a) -> m (SlideLayoutsOf a))
-> Traversable SlideLayoutsOf
(a -> f b) -> SlideLayoutsOf a -> f (SlideLayoutsOf b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
SlideLayoutsOf (m a) -> m (SlideLayoutsOf a)
forall (f :: * -> *) a.
Applicative f =>
SlideLayoutsOf (f a) -> f (SlideLayoutsOf a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SlideLayoutsOf a -> m (SlideLayoutsOf b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SlideLayoutsOf a -> f (SlideLayoutsOf b)
sequence :: SlideLayoutsOf (m a) -> m (SlideLayoutsOf a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
SlideLayoutsOf (m a) -> m (SlideLayoutsOf a)
mapM :: (a -> m b) -> SlideLayoutsOf a -> m (SlideLayoutsOf b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SlideLayoutsOf a -> m (SlideLayoutsOf b)
sequenceA :: SlideLayoutsOf (f a) -> f (SlideLayoutsOf a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
SlideLayoutsOf (f a) -> f (SlideLayoutsOf a)
traverse :: (a -> f b) -> SlideLayoutsOf a -> f (SlideLayoutsOf b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SlideLayoutsOf a -> f (SlideLayoutsOf b)
$cp2Traversable :: Foldable SlideLayoutsOf
$cp1Traversable :: Functor SlideLayoutsOf
Traversable)

data SlideLayout = SlideLayout
  { SlideLayout -> Element
slElement :: Element
  , SlideLayout -> Bool
slInReferenceDoc :: Bool
    -- ^ True if the layout is in the provided reference doc, False if it's in
    -- the default reference doc.
  , SlideLayout -> FilePath
slPath :: FilePath
  , SlideLayout -> Entry
slEntry :: Entry
  } deriving (Int -> SlideLayout -> ShowS
[SlideLayout] -> ShowS
SlideLayout -> FilePath
(Int -> SlideLayout -> ShowS)
-> (SlideLayout -> FilePath)
-> ([SlideLayout] -> ShowS)
-> Show SlideLayout
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [SlideLayout] -> ShowS
$cshowList :: [SlideLayout] -> ShowS
show :: SlideLayout -> FilePath
$cshow :: SlideLayout -> FilePath
showsPrec :: Int -> SlideLayout -> ShowS
$cshowsPrec :: Int -> SlideLayout -> ShowS
Show)

getSlideLayouts :: PandocMonad m => P m SlideLayouts
getSlideLayouts :: P m SlideLayouts
getSlideLayouts = (WriterEnv -> Maybe SlideLayouts)
-> ReaderT WriterEnv (StateT WriterState m) (Maybe SlideLayouts)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Maybe SlideLayouts
envSlideLayouts ReaderT WriterEnv (StateT WriterState m) (Maybe SlideLayouts)
-> (Maybe SlideLayouts -> P m SlideLayouts) -> P m SlideLayouts
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= P m SlideLayouts
-> (SlideLayouts -> P m SlideLayouts)
-> Maybe SlideLayouts
-> P m SlideLayouts
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PandocError -> P m SlideLayouts
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e) SlideLayouts -> P m SlideLayouts
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where
    e :: PandocError
e = Text -> PandocError
PandocSomeError ("Slide layouts aren't defined, even though they should "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "always be. This is a bug in pandoc.")

-- | A placeholder within a layout, identified by type and index.
--
-- E.g., @Placeholder ObjType 2@ is the third placeholder of type 'ObjType' in
-- the layout.
data Placeholder = Placeholder
  { Placeholder -> PHType
placeholderType :: PHType
  , Placeholder -> Int
index :: Int
  } deriving (Int -> Placeholder -> ShowS
[Placeholder] -> ShowS
Placeholder -> FilePath
(Int -> Placeholder -> ShowS)
-> (Placeholder -> FilePath)
-> ([Placeholder] -> ShowS)
-> Show Placeholder
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Placeholder] -> ShowS
$cshowList :: [Placeholder] -> ShowS
show :: Placeholder -> FilePath
$cshow :: Placeholder -> FilePath
showsPrec :: Int -> Placeholder -> ShowS
$cshowsPrec :: Int -> Placeholder -> ShowS
Show, Placeholder -> Placeholder -> Bool
(Placeholder -> Placeholder -> Bool)
-> (Placeholder -> Placeholder -> Bool) -> Eq Placeholder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Placeholder -> Placeholder -> Bool
$c/= :: Placeholder -> Placeholder -> Bool
== :: Placeholder -> Placeholder -> Bool
$c== :: Placeholder -> Placeholder -> Bool
Eq)

-- | Paragraph indentation info.
data Indents = Indents
  { Indents -> Maybe LevelIndents
level1 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level2 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level3 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level4 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level5 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level6 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level7 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level8 :: Maybe LevelIndents
  , Indents -> Maybe LevelIndents
level9 :: Maybe LevelIndents
  } deriving (Int -> Indents -> ShowS
[Indents] -> ShowS
Indents -> FilePath
(Int -> Indents -> ShowS)
-> (Indents -> FilePath) -> ([Indents] -> ShowS) -> Show Indents
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Indents] -> ShowS
$cshowList :: [Indents] -> ShowS
show :: Indents -> FilePath
$cshow :: Indents -> FilePath
showsPrec :: Int -> Indents -> ShowS
$cshowsPrec :: Int -> Indents -> ShowS
Show, Indents -> Indents -> Bool
(Indents -> Indents -> Bool)
-> (Indents -> Indents -> Bool) -> Eq Indents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Indents -> Indents -> Bool
$c/= :: Indents -> Indents -> Bool
== :: Indents -> Indents -> Bool
$c== :: Indents -> Indents -> Bool
Eq)

levelIndent :: Indents -> Int -> Maybe LevelIndents
levelIndent :: Indents -> Int -> Maybe LevelIndents
levelIndent is :: Indents
is index :: Int
index = Indents -> Maybe LevelIndents
getter Indents
is
  where
    getter :: Indents -> Maybe LevelIndents
getter = case Int
index of
      0 -> Indents -> Maybe LevelIndents
level1
      1 -> Indents -> Maybe LevelIndents
level2
      2 -> Indents -> Maybe LevelIndents
level3
      3 -> Indents -> Maybe LevelIndents
level4
      4 -> Indents -> Maybe LevelIndents
level5
      5 -> Indents -> Maybe LevelIndents
level6
      6 -> Indents -> Maybe LevelIndents
level7
      7 -> Indents -> Maybe LevelIndents
level8
      8 -> Indents -> Maybe LevelIndents
level9
      _ -> Maybe LevelIndents -> Indents -> Maybe LevelIndents
forall a b. a -> b -> a
const Maybe LevelIndents
forall a. Maybe a
Nothing

data LevelIndents = LevelIndents
  { LevelIndents -> Pixels
marL :: EMU
  , LevelIndents -> Pixels
indent :: EMU
  } deriving (Int -> LevelIndents -> ShowS
[LevelIndents] -> ShowS
LevelIndents -> FilePath
(Int -> LevelIndents -> ShowS)
-> (LevelIndents -> FilePath)
-> ([LevelIndents] -> ShowS)
-> Show LevelIndents
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LevelIndents] -> ShowS
$cshowList :: [LevelIndents] -> ShowS
show :: LevelIndents -> FilePath
$cshow :: LevelIndents -> FilePath
showsPrec :: Int -> LevelIndents -> ShowS
$cshowsPrec :: Int -> LevelIndents -> ShowS
Show, LevelIndents -> LevelIndents -> Bool
(LevelIndents -> LevelIndents -> Bool)
-> (LevelIndents -> LevelIndents -> Bool) -> Eq LevelIndents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LevelIndents -> LevelIndents -> Bool
$c/= :: LevelIndents -> LevelIndents -> Bool
== :: LevelIndents -> LevelIndents -> Bool
$c== :: LevelIndents -> LevelIndents -> Bool
Eq)

data MediaInfo = MediaInfo { MediaInfo -> FilePath
mInfoFilePath :: FilePath
                           , MediaInfo -> Int
mInfoLocalId  :: Int
                           , MediaInfo -> Int
mInfoGlobalId :: Int
                           , MediaInfo -> Maybe Text
mInfoMimeType :: Maybe MimeType
                           , MediaInfo -> Maybe Text
mInfoExt      :: Maybe T.Text
                           , MediaInfo -> Bool
mInfoCaption  :: Bool
                           } deriving (Int -> MediaInfo -> ShowS
[MediaInfo] -> ShowS
MediaInfo -> FilePath
(Int -> MediaInfo -> ShowS)
-> (MediaInfo -> FilePath)
-> ([MediaInfo] -> ShowS)
-> Show MediaInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MediaInfo] -> ShowS
$cshowList :: [MediaInfo] -> ShowS
show :: MediaInfo -> FilePath
$cshow :: MediaInfo -> FilePath
showsPrec :: Int -> MediaInfo -> ShowS
$cshowsPrec :: Int -> MediaInfo -> ShowS
Show, MediaInfo -> MediaInfo -> Bool
(MediaInfo -> MediaInfo -> Bool)
-> (MediaInfo -> MediaInfo -> Bool) -> Eq MediaInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MediaInfo -> MediaInfo -> Bool
$c/= :: MediaInfo -> MediaInfo -> Bool
== :: MediaInfo -> MediaInfo -> Bool
$c== :: MediaInfo -> MediaInfo -> Bool
Eq)

data WriterState = WriterState { WriterState -> Map Int (Map Int LinkTarget)
stLinkIds :: M.Map Int (M.Map Int LinkTarget)
                               -- (FP, Local ID, Global ID, Maybe Mime)
                               , WriterState -> Map Int [MediaInfo]
stMediaIds :: M.Map Int [MediaInfo]
                               , WriterState -> Map FilePath Int
stMediaGlobalIds :: M.Map FilePath Int
                               , WriterState -> Maybe FooterInfo
stFooterInfo :: Maybe FooterInfo
                               } deriving (Int -> WriterState -> ShowS
[WriterState] -> ShowS
WriterState -> FilePath
(Int -> WriterState -> ShowS)
-> (WriterState -> FilePath)
-> ([WriterState] -> ShowS)
-> Show WriterState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [WriterState] -> ShowS
$cshowList :: [WriterState] -> ShowS
show :: WriterState -> FilePath
$cshow :: WriterState -> FilePath
showsPrec :: Int -> WriterState -> ShowS
$cshowsPrec :: Int -> WriterState -> ShowS
Show, WriterState -> WriterState -> Bool
(WriterState -> WriterState -> Bool)
-> (WriterState -> WriterState -> Bool) -> Eq WriterState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriterState -> WriterState -> Bool
$c/= :: WriterState -> WriterState -> Bool
== :: WriterState -> WriterState -> Bool
$c== :: WriterState -> WriterState -> Bool
Eq)

instance Default WriterState where
  def :: WriterState
def = WriterState :: Map Int (Map Int LinkTarget)
-> Map Int [MediaInfo]
-> Map FilePath Int
-> Maybe FooterInfo
-> WriterState
WriterState { stLinkIds :: Map Int (Map Int LinkTarget)
stLinkIds = Map Int (Map Int LinkTarget)
forall a. Monoid a => a
mempty
                    , stMediaIds :: Map Int [MediaInfo]
stMediaIds = Map Int [MediaInfo]
forall a. Monoid a => a
mempty
                    , stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Map FilePath Int
forall a. Monoid a => a
mempty
                    , stFooterInfo :: Maybe FooterInfo
stFooterInfo = Maybe FooterInfo
forall a. Maybe a
Nothing
                    }

type P m = ReaderT WriterEnv (StateT WriterState m)

runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
runP :: WriterEnv -> WriterState -> P m a -> m a
runP env :: WriterEnv
env st :: WriterState
st p :: P m a
p = StateT WriterState m a -> WriterState -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (P m a -> WriterEnv -> StateT WriterState m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT P m a
p WriterEnv
env) WriterState
st

--------------------------------------------------------------------

monospaceFont :: Monad m => P m T.Text
monospaceFont :: P m Text
monospaceFont = do
  Context Text
vars <- (WriterEnv -> Context Text)
-> ReaderT WriterEnv (StateT WriterState m) (Context Text)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Context Text
envContext
  case Text -> Context Text -> Maybe Text
forall a b. FromContext a b => Text -> Context a -> Maybe b
lookupContext "monofont" Context Text
vars of
    Just s :: Text
s -> Text -> P m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
    Nothing -> Text -> P m Text
forall (m :: * -> *) a. Monad m => a -> m a
return "Courier"

fontSizeAttributes :: Monad m => RunProps -> P m [(Text, Text)]
fontSizeAttributes :: RunProps -> P m NameSpaces
fontSizeAttributes RunProps { rPropForceSize :: RunProps -> Maybe Pixels
rPropForceSize = Just sz :: Pixels
sz } =
  NameSpaces -> P m NameSpaces
forall (m :: * -> *) a. Monad m => a -> m a
return [("sz", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ Pixels
sz Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 100)]
fontSizeAttributes _ = NameSpaces -> P m NameSpaces
forall (m :: * -> *) a. Monad m => a -> m a
return []

copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
copyFileToArchive :: Archive -> FilePath -> P m Archive
copyFileToArchive arch :: Archive
arch fp :: FilePath
fp = do
  Archive
refArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  case FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
fp Archive
refArchive Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
fp Archive
distArchive of
    Nothing -> PandocError -> P m Archive
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Archive) -> PandocError -> P m Archive
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                          (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack
                          (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
fp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> " missing in reference file"
    Just e :: Entry
e -> Archive -> P m Archive
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive -> P m Archive) -> Archive -> P m Archive
forall a b. (a -> b) -> a -> b
$ Entry -> Archive -> Archive
addEntryToArchive Entry
e Archive
arch

alwaysInheritedPatterns :: [Pattern]
alwaysInheritedPatterns :: [Pattern]
alwaysInheritedPatterns =
  (FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Pattern
compile [ "docProps/app.xml"
              , "ppt/slideLayouts/slideLayout*.xml"
              , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
              , "ppt/slideMasters/slideMaster1.xml"
              , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
              , "ppt/theme/theme*.xml"
              , "ppt/theme/_rels/theme*.xml.rels"
              , "ppt/presProps.xml"
              , "ppt/tableStyles.xml"
              , "ppt/media/image*"
              , "ppt/fonts/*"
              ]

-- We only look for these under special conditions
contingentInheritedPatterns :: Presentation -> [Pattern]
contingentInheritedPatterns :: Presentation -> [Pattern]
contingentInheritedPatterns pres :: Presentation
pres = [] [Pattern] -> [Pattern] -> [Pattern]
forall a. Semigroup a => a -> a -> a
<>
  if Presentation -> Bool
presHasSpeakerNotes Presentation
pres
  then (FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Pattern
compile [ "ppt/notesMasters/notesMaster*.xml"
                   , "ppt/notesMasters/_rels/notesMaster*.xml.rels"
                   ]
  else []

inheritedPatterns :: Presentation -> [Pattern]
inheritedPatterns :: Presentation -> [Pattern]
inheritedPatterns pres :: Presentation
pres =
  [Pattern]
alwaysInheritedPatterns [Pattern] -> [Pattern] -> [Pattern]
forall a. Semigroup a => a -> a -> a
<> Presentation -> [Pattern]
contingentInheritedPatterns Presentation
pres

patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
patternToFilePaths :: Pattern -> P m [FilePath]
patternToFilePaths pat :: Pattern
pat = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive

  let archiveFiles :: [FilePath]
archiveFiles = Archive -> [FilePath]
filesInArchive Archive
refArchive [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
`union` Archive -> [FilePath]
filesInArchive Archive
distArchive
  [FilePath] -> P m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> P m [FilePath]) -> [FilePath] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match Pattern
pat) [FilePath]
archiveFiles

patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths :: [Pattern] -> P m [FilePath]
patternsToFilePaths pats :: [Pattern]
pats = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> ReaderT WriterEnv (StateT WriterState m) [[FilePath]]
-> P m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> P m [FilePath])
-> [Pattern]
-> ReaderT WriterEnv (StateT WriterState m) [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => Pattern -> P m [FilePath]
patternToFilePaths [Pattern]
pats

-- Here are the files we'll require to make a Powerpoint document. If
-- any of these are missing, we should error out of our build.
requiredFiles :: [FilePath]
requiredFiles :: [FilePath]
requiredFiles = [ "docProps/app.xml"
                , "ppt/presProps.xml"
                , "ppt/slideLayouts/slideLayout1.xml"
                , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
                , "ppt/slideLayouts/slideLayout2.xml"
                , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
                , "ppt/slideLayouts/slideLayout3.xml"
                , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
                , "ppt/slideLayouts/slideLayout4.xml"
                , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
                , "ppt/slideMasters/slideMaster1.xml"
                , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
                , "ppt/theme/theme1.xml"
                , "ppt/tableStyles.xml"
                ]

presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive
presentationToArchiveP :: Presentation -> P m Archive
presentationToArchiveP p :: Presentation
p@(Presentation docProps :: DocProps
docProps slides :: [Slide]
slides) = do
  [FilePath]
filePaths <- [Pattern] -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths ([Pattern] -> P m [FilePath]) -> [Pattern] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ Presentation -> [Pattern]
inheritedPatterns Presentation
p

  -- make sure all required files are available:
  let missingFiles :: [FilePath]
missingFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath]
filePaths) [FilePath]
requiredFiles
  Bool
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
missingFiles)
    (PandocError -> ReaderT WriterEnv (StateT WriterState m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> ReaderT WriterEnv (StateT WriterState m) ())
-> PandocError -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$
      Text -> PandocError
PandocSomeError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
      "The following required files are missing:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      [Text] -> Text
T.unlines ((FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Text
T.pack (FilePath -> Text) -> ShowS -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("  " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) [FilePath]
missingFiles)
    )

  Archive
newArch <- (Archive -> FilePath -> P m Archive)
-> Archive -> [FilePath] -> P m Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Archive -> FilePath -> P m Archive
forall (m :: * -> *).
PandocMonad m =>
Archive -> FilePath -> P m Archive
copyFileToArchive Archive
emptyArchive [FilePath]
filePaths

  -- Add any layouts taken from the default archive,
  -- overwriting any already added.
  SlideLayouts
slideLayouts <- P m SlideLayouts
forall (m :: * -> *). PandocMonad m => P m SlideLayouts
getSlideLayouts
  let f :: SlideLayout -> Archive -> Archive
f layout :: SlideLayout
layout =
        if Bool -> Bool
not (SlideLayout -> Bool
slInReferenceDoc SlideLayout
layout)
        then Entry -> Archive -> Archive
addEntryToArchive (SlideLayout -> Entry
slEntry SlideLayout
layout)
        else Archive -> Archive
forall a. a -> a
id
  let newArch' :: Archive
newArch' = (SlideLayout -> Archive -> Archive)
-> Archive -> SlideLayouts -> Archive
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SlideLayout -> Archive -> Archive
f Archive
newArch SlideLayouts
slideLayouts

  Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMaster
  Archive
refArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Element
presentationElement <- Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/presentation.xml"
  (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: WriterState
s ->
    WriterState
s {stFooterInfo :: Maybe FooterInfo
stFooterInfo =
        Maybe Text
-> SlideLayouts -> Element -> Element -> Maybe FooterInfo
getFooterInfo (DocProps -> Maybe Text
dcDate DocProps
docProps) SlideLayouts
slideLayouts Element
master Element
presentationElement
      })

  -- Update the master to make sure it includes any layouts we've just added
  Element
masterRels <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMasterRels
  let (updatedMasterElem :: Element
updatedMasterElem, updatedMasterRelElem :: Element
updatedMasterRelElem) = SlideLayouts -> Element -> Element -> (Element, Element)
updateMasterElems SlideLayouts
slideLayouts Element
master Element
masterRels
  Entry
updatedMasterEntry <- FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/slideMasters/slideMaster1.xml" Element
updatedMasterElem
  Entry
updatedMasterRelEntry <- FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/slideMasters/_rels/slideMaster1.xml.rels" Element
updatedMasterRelElem

  -- we make a modified ppt/viewProps.xml out of the presentation viewProps
  Entry
viewPropsEntry <- P m Entry
forall (m :: * -> *). PandocMonad m => P m Entry
makeViewPropsEntry
  -- we make a docProps/core.xml entry out of the presentation docprops
  Entry
docPropsEntry <- DocProps -> P m Entry
forall (m :: * -> *). PandocMonad m => DocProps -> P m Entry
docPropsToEntry DocProps
docProps
  -- we make a docProps/custom.xml entry out of the custom properties
  Entry
docCustomPropsEntry <- DocProps -> P m Entry
forall (m :: * -> *). PandocMonad m => DocProps -> P m Entry
docCustomPropsToEntry DocProps
docProps
  -- we make this ourself in case there's something unexpected in the
  -- one in the reference doc.
  Entry
relsEntry <- P m Entry
forall (m :: * -> *). PandocMonad m => P m Entry
topLevelRelsEntry
  -- presentation entry and rels.
  (presentationRIdUpdateData :: PresentationRIdUpdateData
presentationRIdUpdateData, presRelsEntry :: Entry
presRelsEntry) <- Presentation -> P m (PresentationRIdUpdateData, Entry)
forall (m :: * -> *).
PandocMonad m =>
Presentation -> P m (PresentationRIdUpdateData, Entry)
presentationToRelsEntry Presentation
p
  Entry
presEntry <- PresentationRIdUpdateData -> Presentation -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
PresentationRIdUpdateData -> Presentation -> P m Entry
presentationToPresEntry PresentationRIdUpdateData
presentationRIdUpdateData Presentation
p
  [Entry]
slideEntries <- (Slide -> P m Entry)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> P m Entry
forall (m :: * -> *). PandocMonad m => Slide -> P m Entry
slideToEntry [Slide]
slides
  [Entry]
slideRelEntries <- (Slide -> P m Entry)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> P m Entry
forall (m :: * -> *). PandocMonad m => Slide -> P m Entry
slideToSlideRelEntry [Slide]
slides
  [Entry]
spkNotesEntries <- [Maybe Entry] -> [Entry]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Entry] -> [Entry])
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
-> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry))
-> [Slide]
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry [Slide]
slides
  [Entry]
spkNotesRelEntries <- [Maybe Entry] -> [Entry]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Entry] -> [Entry])
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
-> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry))
-> [Slide]
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry [Slide]
slides
  -- These have to come after everything, because they need the info
  -- built up in the state.
  [Entry]
mediaEntries <- ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (m :: * -> *). PandocMonad m => P m [Entry]
makeMediaEntries
  Entry
contentTypesEntry <- Presentation -> P m ContentTypes
forall (m :: * -> *).
PandocMonad m =>
Presentation -> P m ContentTypes
presentationToContentTypes Presentation
p P m ContentTypes -> (ContentTypes -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ContentTypes -> P m Entry
forall (m :: * -> *). PandocMonad m => ContentTypes -> P m Entry
contentTypesToEntry
  -- fold everything into our inherited archive and return it.
  Archive -> P m Archive
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive -> P m Archive) -> Archive -> P m Archive
forall a b. (a -> b) -> a -> b
$ (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
newArch' ([Entry] -> Archive) -> [Entry] -> Archive
forall a b. (a -> b) -> a -> b
$
    [Entry]
slideEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry]
slideRelEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry]
spkNotesEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry]
spkNotesRelEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry]
mediaEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry
updatedMasterEntry, Entry
updatedMasterRelEntry]  [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
    [Entry
contentTypesEntry, Entry
docPropsEntry, Entry
docCustomPropsEntry, Entry
relsEntry,
     Entry
presEntry, Entry
presRelsEntry, Entry
viewPropsEntry]

updateMasterElems :: SlideLayouts -> Element -> Element -> (Element, Element)
updateMasterElems :: SlideLayouts -> Element -> Element -> (Element, Element)
updateMasterElems layouts :: SlideLayouts
layouts master :: Element
master masterRels :: Element
masterRels = (Element
updatedMaster, Element
updatedMasterRels)
  where
    updatedMaster :: Element
updatedMaster = Element
master { elContent :: [Content]
elContent = Content -> Content
updateSldLayoutIdLst (Content -> Content) -> [Content] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> [Content]
elContent Element
master }
    (updatedRelationshipIds :: [Text]
updatedRelationshipIds, updatedMasterRels :: Element
updatedMasterRels) = Element -> ([Text], Element)
addLayoutRels Element
masterRels

    updateSldLayoutIdLst :: Content -> Content
    updateSldLayoutIdLst :: Content -> Content
updateSldLayoutIdLst (Elem e :: Element
e) = case Element -> QName
elName Element
e of
      (QName "sldLayoutIdLst" _ _) -> let
        mkChild :: Text -> (a, [Content]) -> (a, [Content])
mkChild relationshipId :: Text
relationshipId (lastId :: a
lastId, children :: [Content]
children) = let
          thisId :: a
thisId = a
lastId a -> a -> a
forall a. Num a => a -> a -> a
+ 1
          newChild :: Element
newChild = Element :: QName -> [Attr] -> [Content] -> Maybe Pixels -> Element
Element
            { elName :: QName
elName = Text -> Maybe Text -> Maybe Text -> QName
QName "sldLayoutId" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just "p")
            , elAttribs :: [Attr]
elAttribs =
              [ QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) (FilePath -> Text
T.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
thisId))
              , QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just "r")) Text
relationshipId
              ]
            , elContent :: [Content]
elContent = []
            , elLine :: Maybe Pixels
elLine = Maybe Pixels
forall a. Maybe a
Nothing
            }
          in (a
thisId, Element -> Content
Elem Element
newChild Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
children)
        newChildren :: [Content]
newChildren = (Pixels, [Content]) -> [Content]
forall a b. (a, b) -> b
snd ((Text -> (Pixels, [Content]) -> (Pixels, [Content]))
-> (Pixels, [Content]) -> [Text] -> (Pixels, [Content])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> (Pixels, [Content]) -> (Pixels, [Content])
forall a.
(Num a, Show a) =>
Text -> (a, [Content]) -> (a, [Content])
mkChild (Element -> Pixels
maxIdNumber' Element
e, []) [Text]
updatedRelationshipIds)
        in Element -> Content
Elem Element
e { elContent :: [Content]
elContent = Element -> [Content]
elContent Element
e [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
newChildren }
      _ -> Element -> Content
Elem Element
e
    updateSldLayoutIdLst c :: Content
c = Content
c

    addLayoutRels ::
      Element ->
      ([Text], Element)
    addLayoutRels :: Element -> ([Text], Element)
addLayoutRels e :: Element
e = let
      layoutsToAdd :: [SlideLayout]
layoutsToAdd = (SlideLayout -> Bool) -> [SlideLayout] -> [SlideLayout]
forall a. (a -> Bool) -> [a] -> [a]
filter (\l :: SlideLayout
l -> Bool -> Bool
not (SlideLayout -> Bool
slInReferenceDoc SlideLayout
l) Bool -> Bool -> Bool
&& Element -> SlideLayout -> Bool
isNew Element
e SlideLayout
l)
                            (SlideLayouts -> [SlideLayout]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SlideLayouts
layouts)
      newRelationships :: [Content]
newRelationships = (Pixels, [Content]) -> [Content]
forall a b. (a, b) -> b
snd ((SlideLayout -> (Pixels, [Content]) -> (Pixels, [Content]))
-> (Pixels, [Content]) -> [SlideLayout] -> (Pixels, [Content])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SlideLayout -> (Pixels, [Content]) -> (Pixels, [Content])
forall a.
(Num a, Show a) =>
SlideLayout -> (a, [Content]) -> (a, [Content])
mkRelationship (Element -> Pixels
maxIdNumber Element
e, []) [SlideLayout]
layoutsToAdd)
      newRelationshipIds :: [Text]
newRelationshipIds =
        (Content -> Maybe Text) -> [Content] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (QName -> Content -> Maybe Text
findElemAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)) [Content]
newRelationships
      mkRelationship :: SlideLayout -> (a, [Content]) -> (a, [Content])
mkRelationship layout :: SlideLayout
layout (lastId :: a
lastId, relationships :: [Content]
relationships) = let
        thisId :: a
thisId = a
lastId a -> a -> a
forall a. Num a => a -> a -> a
+ 1
        slideLayoutPath :: Text
slideLayoutPath = "../slideLayouts/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (ShowS
takeFileName (SlideLayout -> FilePath
slPath SlideLayout
layout))
        newRelationship :: Element
newRelationship = Element :: QName -> [Attr] -> [Content] -> Maybe Pixels -> Element
Element
          { elName :: QName
elName = Text -> Maybe Text -> Maybe Text -> QName
QName "Relationship" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
          , elAttribs :: [Attr]
elAttribs =
            [ QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) ("rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
thisId))
            , QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName "Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout"
            , QName -> Text -> Attr
Attr (Text -> Maybe Text -> Maybe Text -> QName
QName "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Text
slideLayoutPath
            ]
          , elContent :: [Content]
elContent = []
          , elLine :: Maybe Pixels
elLine = Maybe Pixels
forall a. Maybe a
Nothing
          }
        in (a
thisId, Element -> Content
Elem Element
newRelationship Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
relationships)
      in ([Text]
newRelationshipIds, Element
e {elContent :: [Content]
elContent = Element -> [Content]
elContent Element
e [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
newRelationships})

    -- Whether the layout needs to be added to the Relationships element.
    isNew :: Element -> SlideLayout -> Bool
    isNew :: Element -> SlideLayout -> Bool
isNew relationships :: Element
relationships SlideLayout{..} = let
      toDetails :: Content -> Maybe FilePath
toDetails = (Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
takeFileName ShowS -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack)
        (Maybe Text -> Maybe FilePath)
-> (Content -> Maybe Text) -> Content -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Content -> Maybe Text
findElemAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
      in ShowS
takeFileName FilePath
slPath FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Content -> Maybe FilePath) -> [Content] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Content -> Maybe FilePath
toDetails (Element -> [Content]
elContent Element
relationships)

    findElemAttr :: QName -> Content -> Maybe Text
    findElemAttr :: QName -> Content -> Maybe Text
findElemAttr attr :: QName
attr (Elem e :: Element
e) = QName -> Element -> Maybe Text
findAttr QName
attr Element
e
    findElemAttr _ _ = Maybe Text
forall a. Maybe a
Nothing

    maxIdNumber :: Element -> Integer
    maxIdNumber :: Element -> Pixels
maxIdNumber relationships :: Element
relationships = [Pixels] -> Pixels
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Pixels -> [Pixels] -> [Pixels]
forall a. a -> [a] -> [a]
: [Pixels]
idNumbers)
      where
        idNumbers :: [Pixels]
idNumbers = (Text -> Maybe Pixels) -> [Text] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> Maybe Pixels
readTextAsInteger (Text -> Maybe Pixels) -> (Text -> Text) -> Text -> Maybe Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop 3) [Text]
idAttributes
        idAttributes :: [Text]
idAttributes = (Content -> Maybe Text) -> [Content] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Content -> Maybe Text
getIdAttribute (Element -> [Content]
elContent Element
relationships)
        getIdAttribute :: Content -> Maybe Text
getIdAttribute (Elem e :: Element
e) = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e
        getIdAttribute _ = Maybe Text
forall a. Maybe a
Nothing

    maxIdNumber' :: Element -> Integer
    maxIdNumber' :: Element -> Pixels
maxIdNumber' sldLayouts :: Element
sldLayouts = [Pixels] -> Pixels
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Pixels -> [Pixels] -> [Pixels]
forall a. a -> [a] -> [a]
: [Pixels]
idNumbers)
      where
        idNumbers :: [Pixels]
idNumbers = (Text -> Maybe Pixels) -> [Text] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Pixels
readTextAsInteger [Text]
idAttributes
        idAttributes :: [Text]
idAttributes = (Content -> Maybe Text) -> [Content] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Content -> Maybe Text
getIdAttribute (Element -> [Content]
elContent Element
sldLayouts)
        getIdAttribute :: Content -> Maybe Text
getIdAttribute (Elem e :: Element
e) = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e
        getIdAttribute _ = Maybe Text
forall a. Maybe a
Nothing

data FooterInfo = FooterInfo
  { FooterInfo -> SlideLayoutsOf (Maybe Element)
fiDate :: SlideLayoutsOf (Maybe Element)
  , FooterInfo -> SlideLayoutsOf (Maybe Element)
fiFooter :: SlideLayoutsOf (Maybe Element)
  , FooterInfo -> SlideLayoutsOf (Maybe Element)
fiSlideNumber :: SlideLayoutsOf (Maybe Element)
  , FooterInfo -> Bool
fiShowOnFirstSlide :: Bool
  } deriving (Int -> FooterInfo -> ShowS
[FooterInfo] -> ShowS
FooterInfo -> FilePath
(Int -> FooterInfo -> ShowS)
-> (FooterInfo -> FilePath)
-> ([FooterInfo] -> ShowS)
-> Show FooterInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FooterInfo] -> ShowS
$cshowList :: [FooterInfo] -> ShowS
show :: FooterInfo -> FilePath
$cshow :: FooterInfo -> FilePath
showsPrec :: Int -> FooterInfo -> ShowS
$cshowsPrec :: Int -> FooterInfo -> ShowS
Show, FooterInfo -> FooterInfo -> Bool
(FooterInfo -> FooterInfo -> Bool)
-> (FooterInfo -> FooterInfo -> Bool) -> Eq FooterInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FooterInfo -> FooterInfo -> Bool
$c/= :: FooterInfo -> FooterInfo -> Bool
== :: FooterInfo -> FooterInfo -> Bool
$c== :: FooterInfo -> FooterInfo -> Bool
Eq)

getFooterInfo :: Maybe Text -> SlideLayouts -> Element -> Element -> Maybe FooterInfo
getFooterInfo :: Maybe Text
-> SlideLayouts -> Element -> Element -> Maybe FooterInfo
getFooterInfo date :: Maybe Text
date layouts :: SlideLayouts
layouts master :: Element
master presentation :: Element
presentation = do
  let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
master
  Element
hf <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "hf") Element
master
  let fiDate :: SlideLayoutsOf (Maybe Element)
fiDate = let
        f :: Element -> Element
f layoutDate :: Element
layoutDate =
          case Maybe Text
date of
            Nothing -> Element
layoutDate
            Just d :: Text
d ->
              if NameSpaces -> Element -> Bool
dateIsAutomatic (Element -> NameSpaces
elemToNameSpaces Element
layoutDate) Element
layoutDate
              then Element
layoutDate
              else Text -> Element -> Element
replaceDate Text
d Element
layoutDate
        in (Element -> Element) -> Maybe Element -> Maybe Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Element
f (Maybe Element -> Maybe Element)
-> (SlideLayout -> Maybe Element) -> SlideLayout -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Element -> Element -> Maybe Element
getShape "dt" Element
hf (Element -> Maybe Element)
-> (SlideLayout -> Element) -> SlideLayout -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlideLayout -> Element
slElement (SlideLayout -> Maybe Element)
-> SlideLayouts -> SlideLayoutsOf (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlideLayouts
layouts
      fiFooter :: SlideLayoutsOf (Maybe Element)
fiFooter = Text -> Element -> Element -> Maybe Element
getShape "ftr" Element
hf (Element -> Maybe Element)
-> (SlideLayout -> Element) -> SlideLayout -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlideLayout -> Element
slElement (SlideLayout -> Maybe Element)
-> SlideLayouts -> SlideLayoutsOf (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlideLayouts
layouts
      fiSlideNumber :: SlideLayoutsOf (Maybe Element)
fiSlideNumber = Text -> Element -> Element -> Maybe Element
getShape "sldNum" Element
hf (Element -> Maybe Element)
-> (SlideLayout -> Element) -> SlideLayout -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlideLayout -> Element
slElement (SlideLayout -> Maybe Element)
-> SlideLayouts -> SlideLayoutsOf (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlideLayouts
layouts
      fiShowOnFirstSlide :: Bool
fiShowOnFirstSlide =
        Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True
        (Text -> Element -> Maybe Bool
getBooleanAttribute "showSpecialPlsOnTitleSld" Element
presentation)
  FooterInfo -> Maybe FooterInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure FooterInfo :: SlideLayoutsOf (Maybe Element)
-> SlideLayoutsOf (Maybe Element)
-> SlideLayoutsOf (Maybe Element)
-> Bool
-> FooterInfo
FooterInfo{..}
    where
      getShape :: Text -> Element -> Element -> Maybe Element
getShape t :: Text
t hf :: Element
hf layout :: Element
layout =
        if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Text -> Element -> Maybe Bool
getBooleanAttribute Text
t Element
hf)
        then do
          let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
layout
          Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
          Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
          let containsPlaceholder :: Element -> Bool
containsPlaceholder sp :: Element
sp = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
                Element
nvSpPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
sp
                Element
nvPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvPr") Element
nvSpPr
                Element
ph <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "ph") Element
nvPr
                Text
placeholderType <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
ph
                Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
placeholderType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t)
          [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe ((Element -> Bool) -> Element -> [Element]
filterChildren Element -> Bool
containsPlaceholder Element
spTree)
        else Maybe Element
forall a. Maybe a
Nothing

      dateIsAutomatic :: NameSpaces -> Element -> Bool
      dateIsAutomatic :: NameSpaces -> Element -> Bool
dateIsAutomatic ns :: NameSpaces
ns shape :: Element
shape = Maybe Element -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Element -> Bool) -> Maybe Element -> Bool
forall a b. (a -> b) -> a -> b
$ do
        Element
txBody <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "txBody") Element
shape
        Element
p <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "p") Element
txBody
        QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "fld") Element
p

      replaceDate :: Text -> Element -> Element
      replaceDate :: Text -> Element -> Element
replaceDate newDate :: Text
newDate e :: Element
e =
        Element
e { elContent :: [Content]
elContent =
            case (Element -> QName
elName Element
e) of
              QName "t" _ (Just "a") ->
                [ CData -> Content
Text (CData :: CDataKind -> Text -> Maybe Pixels -> CData
CData { cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataText
                              , cdData :: Text
cdData = Text
newDate
                              , cdLine :: Maybe Pixels
cdLine = Maybe Pixels
forall a. Maybe a
Nothing
                              })
                ]
              _ -> (Element -> Element) -> Content -> Content
ifElem (Text -> Element -> Element
replaceDate Text
newDate) (Content -> Content) -> [Content] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> [Content]
elContent Element
e
           }

      ifElem :: (Element -> Element) -> (Content -> Content)
      ifElem :: (Element -> Element) -> Content -> Content
ifElem f :: Element -> Element
f (Elem e :: Element
e) = Element -> Content
Elem (Element -> Element
f Element
e)
      ifElem _ c :: Content
c = Content
c

      getBooleanAttribute :: Text -> Element -> Maybe Bool
getBooleanAttribute t :: Text
t e :: Element
e =
        (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["1", "true"]) (Text -> Bool) -> Maybe Text -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          (QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
t Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e)

footerElements ::
  PandocMonad m =>
  (forall a. SlideLayoutsOf a -> a) ->
  P m [Content]
footerElements :: (forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements layout :: forall a. SlideLayoutsOf a -> a
layout = do
  Maybe FooterInfo
footerInfo <- (WriterState -> Maybe FooterInfo)
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FooterInfo)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Maybe FooterInfo
stFooterInfo
  [Content] -> P m [Content]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ([Content] -> P m [Content]) -> [Content] -> P m [Content]
forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem (Element -> Content) -> [Element] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe FooterInfo
footerInfo Maybe FooterInfo -> (FooterInfo -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlideLayoutsOf (Maybe Element) -> Maybe Element
forall a. SlideLayoutsOf a -> a
layout (SlideLayoutsOf (Maybe Element) -> Maybe Element)
-> (FooterInfo -> SlideLayoutsOf (Maybe Element))
-> FooterInfo
-> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FooterInfo -> SlideLayoutsOf (Maybe Element)
fiDate)
       [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe FooterInfo
footerInfo Maybe FooterInfo -> (FooterInfo -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlideLayoutsOf (Maybe Element) -> Maybe Element
forall a. SlideLayoutsOf a -> a
layout (SlideLayoutsOf (Maybe Element) -> Maybe Element)
-> (FooterInfo -> SlideLayoutsOf (Maybe Element))
-> FooterInfo
-> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FooterInfo -> SlideLayoutsOf (Maybe Element)
fiFooter)
       [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe FooterInfo
footerInfo Maybe FooterInfo -> (FooterInfo -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlideLayoutsOf (Maybe Element) -> Maybe Element
forall a. SlideLayoutsOf a -> a
layout (SlideLayoutsOf (Maybe Element) -> Maybe Element)
-> (FooterInfo -> SlideLayoutsOf (Maybe Element))
-> FooterInfo
-> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FooterInfo -> SlideLayoutsOf (Maybe Element)
fiSlideNumber))

makeSlideIdMap :: Presentation -> M.Map SlideId Int
makeSlideIdMap :: Presentation -> Map SlideId Int
makeSlideIdMap (Presentation _ slides :: [Slide]
slides) =
  [(SlideId, Int)] -> Map SlideId Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SlideId, Int)] -> Map SlideId Int)
-> [(SlideId, Int)] -> Map SlideId Int
forall a b. (a -> b) -> a -> b
$ (Slide -> SlideId) -> [Slide] -> [SlideId]
forall a b. (a -> b) -> [a] -> [b]
map Slide -> SlideId
slideId [Slide]
slides [SlideId] -> [Int] -> [(SlideId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]

makeSpeakerNotesMap :: Presentation -> M.Map Int Int
makeSpeakerNotesMap :: Presentation -> Map Int Int
makeSpeakerNotesMap (Presentation _ slides :: [Slide]
slides) =
  [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Int)] -> Map Int Int) -> [(Int, Int)] -> Map Int Int
forall a b. (a -> b) -> a -> b
$
    ((Slide, Int) -> Maybe Int) -> [(Slide, Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Slide, Int) -> Maybe Int
forall a. (Slide, a) -> Maybe a
f ([Slide]
slides [Slide] -> [Int] -> [(Slide, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]) [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]
  where f :: (Slide, a) -> Maybe a
f (Slide _ _ notes :: SpeakerNotes
notes _, n :: a
n) = if SpeakerNotes
notes SpeakerNotes -> SpeakerNotes -> Bool
forall a. Eq a => a -> a -> Bool
== SpeakerNotes
forall a. Monoid a => a
mempty
                                   then Maybe a
forall a. Maybe a
Nothing
                                   else a -> Maybe a
forall a. a -> Maybe a
Just a
n

presentationToArchive :: PandocMonad m
                      => WriterOptions -> Meta -> Presentation -> m Archive
presentationToArchive :: WriterOptions -> Meta -> Presentation -> m Archive
presentationToArchive opts :: WriterOptions
opts meta :: Meta
meta pres :: Presentation
pres = do
  Archive
distArchive <- ByteString -> Archive
toArchive (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                      FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readDefaultDataFile "reference.pptx"
  Archive
refArchive <- case WriterOptions -> Maybe FilePath
writerReferenceDoc WriterOptions
opts of
                     Just f :: FilePath
f  -> ByteString -> Archive
toArchive (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readFileLazy FilePath
f
                     Nothing -> ByteString -> Archive
toArchive (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readDataFile "reference.pptx"

  let (referenceLayouts :: Map (CI Text) (NonEmpty (Element, FilePath, Entry))
referenceLayouts, defaultReferenceLayouts :: Map (CI Text) (NonEmpty (Element, FilePath, Entry))
defaultReferenceLayouts) =
        (Archive -> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
getLayoutsFromArchive Archive
refArchive, Archive -> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
getLayoutsFromArchive Archive
distArchive)
  let layoutTitles :: SlideLayoutsOf Text
layoutTitles = SlideLayouts :: forall a. a -> a -> a -> a -> a -> a -> a -> SlideLayoutsOf a
SlideLayouts { metadata :: Text
metadata = "Title Slide" :: Text
                                  , title :: Text
title = "Section Header"
                                  , content :: Text
content = "Title and Content"
                                  , twoColumn :: Text
twoColumn = "Two Content"
                                  , comparison :: Text
comparison = "Comparison"
                                  , contentWithCaption :: Text
contentWithCaption = "Content with Caption"
                                  , blank :: Text
blank = "Blank"
                                  }
  SlideLayouts
layouts <- SlideLayoutsOf Text -> (Text -> m SlideLayout) -> m SlideLayouts
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for SlideLayoutsOf Text
layoutTitles ((Text -> m SlideLayout) -> m SlideLayouts)
-> (Text -> m SlideLayout) -> m SlideLayouts
forall a b. (a -> b) -> a -> b
$ \layoutTitle :: Text
layoutTitle -> do
        let layout :: Maybe (NonEmpty (Element, FilePath, Entry))
layout = CI Text
-> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
-> Maybe (NonEmpty (Element, FilePath, Entry))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
layoutTitle) Map (CI Text) (NonEmpty (Element, FilePath, Entry))
referenceLayouts
        let defaultLayout :: Maybe (NonEmpty (Element, FilePath, Entry))
defaultLayout = CI Text
-> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
-> Maybe (NonEmpty (Element, FilePath, Entry))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk Text
layoutTitle) Map (CI Text) (NonEmpty (Element, FilePath, Entry))
defaultReferenceLayouts
        case (Maybe (NonEmpty (Element, FilePath, Entry))
layout, Maybe (NonEmpty (Element, FilePath, Entry))
defaultLayout) of
          (Nothing, Nothing) ->
            PandocError -> m SlideLayout
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> PandocError
PandocSomeError ("Couldn't find layout named \""
                                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
layoutTitle Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" in the provided "
                                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "reference doc or in the default "
                                         Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "reference doc included with pandoc."))
          (Nothing, Just ((element :: Element
element, path :: FilePath
path, entry :: Entry
entry) :| _)) -> do
            LogMessage -> m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
P.report (Text -> LogMessage
PowerpointTemplateWarning
                                     ("Couldn't find layout named \""
                                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
layoutTitle Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" in provided "
                                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "reference doc. Falling back to "
                                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "the default included with pandoc."))
            SlideLayout -> m SlideLayout
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlideLayout :: Element -> Bool -> FilePath -> Entry -> SlideLayout
SlideLayout { slElement :: Element
slElement = Element
element
                             , slPath :: FilePath
slPath = FilePath
path
                             , slEntry :: Entry
slEntry = Entry
entry
                             , slInReferenceDoc :: Bool
slInReferenceDoc = Bool
False
                             }
          (Just ((element :: Element
element, path :: FilePath
path, entry :: Entry
entry) :| _), _ ) ->
            SlideLayout -> m SlideLayout
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlideLayout :: Element -> Bool -> FilePath -> Entry -> SlideLayout
SlideLayout { slElement :: Element
slElement = Element
element
                             , slPath :: FilePath
slPath = FilePath
path
                             , slEntry :: Entry
slEntry = Entry
entry
                             , slInReferenceDoc :: Bool
slInReferenceDoc = Bool
True
                             }

  Element
master <- Archive -> Archive -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m Element
getMaster' Archive
refArchive Archive
distArchive

  let otherStyleIndents :: Maybe Indents
otherStyleIndents = do
        let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
master
        Element
txStyles <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "txStyles") Element
master
        Element
otherStyle <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "otherStyle") Element
txStyles
        let makeLevelIndents :: Text -> Maybe LevelIndents
makeLevelIndents name :: Text
name = do
              Element
e <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" Text
name) Element
otherStyle
              LevelIndents -> Maybe LevelIndents
forall (f :: * -> *) a. Applicative f => a -> f a
pure LevelIndents :: Pixels -> Pixels -> LevelIndents
LevelIndents
                { indent :: Pixels
indent = Pixels -> Maybe Pixels -> Pixels
forall a. a -> Maybe a -> a
fromMaybe (-342900)
                    (QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "indent" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e
                    Maybe Text -> (Text -> Maybe Pixels) -> Maybe Pixels
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Pixels
readTextAsInteger)
                , marL :: Pixels
marL = Pixels -> Maybe Pixels -> Pixels
forall a. a -> Maybe a -> a
fromMaybe 347663
                    (QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "marL" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e
                     Maybe Text -> (Text -> Maybe Pixels) -> Maybe Pixels
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Pixels
readTextAsInteger)
                }
        Indents -> Maybe Indents
forall (f :: * -> *) a. Applicative f => a -> f a
pure Indents :: Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Maybe LevelIndents
-> Indents
Indents
          { level1 :: Maybe LevelIndents
level1 = Text -> Maybe LevelIndents
makeLevelIndents "lvl1pPr"
          , level2 :: Maybe LevelIndents
level2 = Text -> Maybe LevelIndents
makeLevelIndents "lvl2pPr"
          , level3 :: Maybe LevelIndents
level3 = Text -> Maybe LevelIndents
makeLevelIndents "lvl3pPr"
          , level4 :: Maybe LevelIndents
level4 = Text -> Maybe LevelIndents
makeLevelIndents "lvl4pPr"
          , level5 :: Maybe LevelIndents
level5 = Text -> Maybe LevelIndents
makeLevelIndents "lvl5pPr"
          , level6 :: Maybe LevelIndents
level6 = Text -> Maybe LevelIndents
makeLevelIndents "lvl6pPr"
          , level7 :: Maybe LevelIndents
level7 = Text -> Maybe LevelIndents
makeLevelIndents "lvl7pPr"
          , level8 :: Maybe LevelIndents
level8 = Text -> Maybe LevelIndents
makeLevelIndents "lvl8pPr"
          , level9 :: Maybe LevelIndents
level9 = Text -> Maybe LevelIndents
makeLevelIndents "lvl9pPr"
          }

  UTCTime
utctime <- m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getTimestamp

  (Pixels, Pixels)
presSize <- case Archive -> Archive -> Maybe (Pixels, Pixels)
getPresentationSize Archive
refArchive Archive
distArchive of
                Just sz :: (Pixels, Pixels)
sz -> (Pixels, Pixels) -> m (Pixels, Pixels)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixels, Pixels)
sz
                Nothing -> PandocError -> m (Pixels, Pixels)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m (Pixels, Pixels))
-> PandocError -> m (Pixels, Pixels)
forall a b. (a -> b) -> a -> b
$
                           Text -> PandocError
PandocSomeError
                           "Could not determine presentation size"

  -- note, we need writerTemplate to be Just _ or metaToContext does
  -- nothing
  Context Text
context <- WriterOptions
-> ([Block] -> m (Doc Text))
-> ([Inline] -> m (Doc Text))
-> Meta
-> m (Context Text)
forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
WriterOptions
-> ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a))
-> Meta
-> m (Context a)
metaToContext WriterOptions
opts{ writerTemplate :: Maybe (Template Text)
writerTemplate =
                                  WriterOptions -> Maybe (Template Text)
writerTemplate WriterOptions
opts Maybe (Template Text)
-> Maybe (Template Text) -> Maybe (Template Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just Template Text
forall a. Monoid a => a
mempty }
                (Doc Text -> m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> m (Doc Text))
-> ([Block] -> Doc Text) -> [Block] -> m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> ([Block] -> Text) -> [Block] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> Text
forall a. Walkable Inline a => a -> Text
stringify)
                (Doc Text -> m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> m (Doc Text))
-> ([Inline] -> Doc Text) -> [Inline] -> m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> ([Inline] -> Text) -> [Inline] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify) Meta
meta

  let env :: WriterEnv
env = WriterEnv
forall a. Default a => a
def { envRefArchive :: Archive
envRefArchive = Archive
refArchive
                , envDistArchive :: Archive
envDistArchive = Archive
distArchive
                , envUTCTime :: UTCTime
envUTCTime = UTCTime
utctime
                , envOpts :: WriterOptions
envOpts = WriterOptions
opts
                , envContext :: Context Text
envContext = Context Text
context
                , envPresentationSize :: (Pixels, Pixels)
envPresentationSize = (Pixels, Pixels)
presSize
                , envSlideIdMap :: Map SlideId Int
envSlideIdMap = Presentation -> Map SlideId Int
makeSlideIdMap Presentation
pres
                , envSpeakerNotesIdMap :: Map Int Int
envSpeakerNotesIdMap = Presentation -> Map Int Int
makeSpeakerNotesMap Presentation
pres
                , envSlideLayouts :: Maybe SlideLayouts
envSlideLayouts = SlideLayouts -> Maybe SlideLayouts
forall a. a -> Maybe a
Just SlideLayouts
layouts
                , envOtherStyleIndents :: Maybe Indents
envOtherStyleIndents = Maybe Indents
otherStyleIndents
                }

  let st :: WriterState
st = WriterState
forall a. Default a => a
def { stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Archive -> Archive -> Map FilePath Int
initialGlobalIds Archive
refArchive Archive
distArchive
               }

  WriterEnv -> WriterState -> P m Archive -> m Archive
forall (m :: * -> *) a.
Monad m =>
WriterEnv -> WriterState -> P m a -> m a
runP WriterEnv
env WriterState
st (P m Archive -> m Archive) -> P m Archive -> m Archive
forall a b. (a -> b) -> a -> b
$ Presentation -> P m Archive
forall (m :: * -> *). PandocMonad m => Presentation -> P m Archive
presentationToArchiveP Presentation
pres

-- | Get all slide layouts from an archive, as a map where the layout's name
-- gives the map key.
--
-- For each layout, the map contains its XML representation, its path within
-- the archive, and the archive entry.
getLayoutsFromArchive :: Archive -> M.Map (CI Text) (NonEmpty (Element, FilePath, Entry))
getLayoutsFromArchive :: Archive -> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
getLayoutsFromArchive archive :: Archive
archive =
  (NonEmpty (Element, FilePath, Entry)
 -> NonEmpty (Element, FilePath, Entry)
 -> NonEmpty (Element, FilePath, Entry))
-> [(CI Text, NonEmpty (Element, FilePath, Entry))]
-> Map (CI Text) (NonEmpty (Element, FilePath, Entry))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith NonEmpty (Element, FilePath, Entry)
-> NonEmpty (Element, FilePath, Entry)
-> NonEmpty (Element, FilePath, Entry)
forall a. Semigroup a => a -> a -> a
(<>) ((\t :: (Element, FilePath, Entry)
t@(e :: Element
e, _, _) -> (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk (Element -> Text
name Element
e), (Element, FilePath, Entry) -> NonEmpty (Element, FilePath, Entry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element, FilePath, Entry)
t)) ((Element, FilePath, Entry)
 -> (CI Text, NonEmpty (Element, FilePath, Entry)))
-> [(Element, FilePath, Entry)]
-> [(CI Text, NonEmpty (Element, FilePath, Entry))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Element, FilePath, Entry)]
layouts)
  where
    layouts :: [(Element, FilePath, Entry)]
    layouts :: [(Element, FilePath, Entry)]
layouts = (FilePath -> Maybe (Element, FilePath, Entry))
-> [FilePath] -> [(Element, FilePath, Entry)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe (Element, FilePath, Entry)
findElementByPath [FilePath]
paths
    parseXml' :: Entry -> Maybe Element
parseXml' entry :: Entry
entry = case Text -> Either Text Element
parseXMLElement (ByteString -> Text
UTF8.toTextLazy (Entry -> ByteString
fromEntry Entry
entry)) of
            Left _ -> Maybe Element
forall a. Maybe a
Nothing
            Right element :: Element
element -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
element
    findElementByPath :: FilePath -> Maybe (Element, FilePath, Entry)
    findElementByPath :: FilePath -> Maybe (Element, FilePath, Entry)
findElementByPath path :: FilePath
path = do
      Entry
entry <- FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
path Archive
archive
      Element
element <- Entry -> Maybe Element
parseXml' Entry
entry
      (Element, FilePath, Entry) -> Maybe (Element, FilePath, Entry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element
element, FilePath
path, Entry
entry)
    paths :: [FilePath]
paths = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match (FilePath -> Pattern
compile "ppt/slideLayouts/slideLayout*.xml")) (Archive -> [FilePath]
filesInArchive Archive
archive)
    name :: Element -> Text
name element :: Element
element = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "Untitled layout" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
            let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
element
            Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
element
            QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "name" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
cSld

--------------------------------------------------

-- Check to see if the presentation has speaker notes. This will
-- influence whether we import the notesMaster template.
presHasSpeakerNotes :: Presentation -> Bool
presHasSpeakerNotes :: Presentation -> Bool
presHasSpeakerNotes (Presentation _ slides :: [Slide]
slides) =
  Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Slide -> Bool) -> [Slide] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((SpeakerNotes
forall a. Monoid a => a
mempty SpeakerNotes -> SpeakerNotes -> Bool
forall a. Eq a => a -> a -> Bool
==) (SpeakerNotes -> Bool) -> (Slide -> SpeakerNotes) -> Slide -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slide -> SpeakerNotes
slideSpeakerNotes) [Slide]
slides

curSlideHasSpeakerNotes :: PandocMonad m => P m Bool
curSlideHasSpeakerNotes :: P m Bool
curSlideHasSpeakerNotes =
  Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Int -> Map Int Int -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Int
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId ReaderT WriterEnv (StateT WriterState m) (Map Int Int -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
-> P m Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap

--------------------------------------------------

getLayout :: PandocMonad m => Layout -> P m Element
getLayout :: Layout -> P m Element
getLayout layout :: Layout
layout = SlideLayouts -> Element
getElement (SlideLayouts -> Element)
-> ReaderT WriterEnv (StateT WriterState m) SlideLayouts
-> P m Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT WriterEnv (StateT WriterState m) SlideLayouts
forall (m :: * -> *). PandocMonad m => P m SlideLayouts
getSlideLayouts
  where
    getElement :: SlideLayouts -> Element
getElement =
      SlideLayout -> Element
slElement (SlideLayout -> Element)
-> (SlideLayouts -> SlideLayout) -> SlideLayouts -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case Layout
layout of
        MetadataSlide{}           -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
metadata
        TitleSlide{}              -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
title
        ContentSlide{}            -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
content
        TwoColumnSlide{}          -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
twoColumn
        ComparisonSlide{}         -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
comparison
        ContentWithCaptionSlide{} -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
contentWithCaption
        BlankSlide{}              -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
blank

shapeHasId :: NameSpaces -> T.Text -> Element -> Bool
shapeHasId :: NameSpaces -> Text -> Element -> Bool
shapeHasId ns :: NameSpaces
ns ident :: Text
ident element :: Element
element = NameSpaces -> Element -> Maybe Text
getShapeId NameSpaces
ns Element
element Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ident

getShapeId :: NameSpaces -> Element -> Maybe Text
getShapeId :: NameSpaces -> Element -> Maybe Text
getShapeId ns :: NameSpaces
ns element :: Element
element = do
  Element
nvSpPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
element
  Element
cNvPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cNvPr") Element
nvSpPr
  QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
cNvPr

type ShapeId = Integer

getContentShape :: PandocMonad m => NameSpaces -> Element -> P m (Maybe ShapeId, Element)
getContentShape :: NameSpaces -> Element -> P m (Maybe Pixels, Element)
getContentShape ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "spTree" Element
spTreeElem = do
      ph :: Placeholder
ph@Placeholder{Int
index :: Int
index :: Placeholder -> Int
index, PHType
placeholderType :: PHType
placeholderType :: Placeholder -> PHType
placeholderType} <- (WriterEnv -> Placeholder)
-> ReaderT WriterEnv (StateT WriterState m) Placeholder
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Placeholder
envPlaceholder
      case Int -> [Element] -> [Element]
forall a. Int -> [a] -> [a]
drop Int
index (NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
placeholderType) of
        sp :: Element
sp : _ -> let
          shapeId :: Maybe Pixels
shapeId = NameSpaces -> Element -> Maybe Text
getShapeId NameSpaces
ns Element
sp Maybe Text -> (Text -> Maybe Pixels) -> Maybe Pixels
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Pixels
readTextAsInteger
          in (Maybe Pixels, Element) -> P m (Maybe Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pixels
shapeId, Element
sp)
        [] -> PandocError -> P m (Maybe Pixels, Element)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m (Maybe Pixels, Element))
-> PandocError -> P m (Maybe Pixels, Element)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ Placeholder -> Text
missingPlaceholderMessage Placeholder
ph
getContentShape _ _ = PandocError -> P m (Maybe Pixels, Element)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m (Maybe Pixels, Element))
-> PandocError -> P m (Maybe Pixels, Element)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                      "Attempted to find content on non shapeTree"

missingPlaceholderMessage :: Placeholder -> Text
missingPlaceholderMessage :: Placeholder -> Text
missingPlaceholderMessage Placeholder{..} =
  "Could not find a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ordinal
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " placeholder of type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
placeholderText
  where
    ordinal :: Text
ordinal = FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
index) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      case (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 100, Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 10) of
        (11, _) -> "th"
        (12, _) -> "th"
        (13, _) -> "th"
        (_,  1) -> "st"
        (_,  2) -> "nd"
        (_,  3) -> "rd"
        _       -> "th"
    placeholderText :: Text
placeholderText = case PHType
placeholderType of
      ObjType -> "obj (or nothing)"
      PHType t :: Text
t -> Text
t

getShapeDimensions :: NameSpaces
                   -> Element
                   -> Maybe ((Integer, Integer), (Integer, Integer))
getShapeDimensions :: NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions ns :: NameSpaces
ns element :: Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
element = do
      Element
spPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spPr") Element
element
      Element
xfrm <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "xfrm") Element
spPr
      Element
off <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "off") Element
xfrm
      Text
xS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "x" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
off
      Text
yS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "y" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
off
      Element
ext <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "ext") Element
xfrm
      Text
cxS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "cx" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
ext
      Text
cyS <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "cy" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
ext
      Pixels
x <- Text -> Maybe Pixels
readTextAsInteger Text
xS
      Pixels
y <- Text -> Maybe Pixels
readTextAsInteger Text
yS
      Pixels
cx <- Text -> Maybe Pixels
readTextAsInteger Text
cxS
      Pixels
cy <- Text -> Maybe Pixels
readTextAsInteger Text
cyS
      ((Pixels, Pixels), (Pixels, Pixels))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pixels
x Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
y Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700),
              (Pixels
cx Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
cy Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700))
  | Bool
otherwise = Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall a. Maybe a
Nothing


getMasterShapeDimensionsById :: T.Text
                             -> Element
                             -> Maybe ((Integer, Integer), (Integer, Integer))
getMasterShapeDimensionsById :: Text -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getMasterShapeDimensionsById ident :: Text
ident master :: Element
master = do
  let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
master
  Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
master
  Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
  Element
sp <- (Element -> Bool) -> Element -> Maybe Element
filterChild (\e :: Element
e -> NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
e Bool -> Bool -> Bool
&& NameSpaces -> Text -> Element -> Bool
shapeHasId NameSpaces
ns Text
ident Element
e) Element
spTree
  NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions NameSpaces
ns Element
sp

getContentShapeSize :: PandocMonad m
                    => NameSpaces
                    -> Element
                    -> Element
                    -> P m ((Integer, Integer), (Integer, Integer))
getContentShapeSize :: NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize ns :: NameSpaces
ns layout :: Element
layout master :: Element
master
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "sldLayout" Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (_, sp :: Element
sp)  <- NameSpaces -> Element -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
NameSpaces -> Element -> P m (Maybe Pixels, Element)
getContentShape NameSpaces
ns Element
spTree
      case NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions NameSpaces
ns Element
sp of
        Just sz :: ((Pixels, Pixels), (Pixels, Pixels))
sz -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pixels, Pixels), (Pixels, Pixels))
sz
        Nothing -> do let mbSz :: Maybe ((Pixels, Pixels), (Pixels, Pixels))
mbSz =
                            QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
sp Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                            QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cNvPr") Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                            QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Maybe Text
-> (Text -> Maybe ((Pixels, Pixels), (Pixels, Pixels)))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                            (Text -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels)))
-> Element -> Text -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getMasterShapeDimensionsById Element
master
                      case Maybe ((Pixels, Pixels), (Pixels, Pixels))
mbSz of
                        Just sz' :: ((Pixels, Pixels), (Pixels, Pixels))
sz' -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pixels, Pixels), (Pixels, Pixels))
sz'
                        Nothing -> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                                   "Couldn't find necessary content shape size"
getContentShapeSize _ _ _ = PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                            "Attempted to find content shape size in non-layout"

buildSpTree :: NameSpaces -> Element -> [Content] -> Element
buildSpTree :: NameSpaces -> Element -> [Content] -> Element
buildSpTree ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem newShapes :: [Content]
newShapes =
  Element
emptySpTreeElem { elContent :: [Content]
elContent = [Content]
newContent }
  where newContent :: [Content]
newContent = Element -> [Content]
elContent Element
emptySpTreeElem [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
newShapes
        emptySpTreeElem :: Element
emptySpTreeElem = Element
spTreeElem { elContent :: [Content]
elContent = (Content -> Bool) -> [Content] -> [Content]
forall a. (a -> Bool) -> [a] -> [a]
filter Content -> Bool
fn (Element -> [Content]
elContent Element
spTreeElem) }
        fn :: Content -> Bool
        fn :: Content -> Bool
fn (Elem e :: Element
e) = NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "nvGrpSpPr" Element
e Bool -> Bool -> Bool
||
                      NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "grpSpPr" Element
e
        fn _        = Bool
True

replaceNamedChildren :: NameSpaces
                     -> Text
                     -> Text
                     -> [Element]
                     -> Element
                     -> Element
replaceNamedChildren :: NameSpaces -> Text -> Text -> [Element] -> Element -> Element
replaceNamedChildren ns :: NameSpaces
ns prefix :: Text
prefix name :: Text
name newKids :: [Element]
newKids element :: Element
element =
  Element
element { elContent :: [Content]
elContent = [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content]) -> [[Content]] -> [Content]
forall a b. (a -> b) -> a -> b
$ Bool -> [Content] -> [[Content]]
fun Bool
True ([Content] -> [[Content]]) -> [Content] -> [[Content]]
forall a b. (a -> b) -> a -> b
$ Element -> [Content]
elContent Element
element }
  where
    fun :: Bool -> [Content] -> [[Content]]
    fun :: Bool -> [Content] -> [[Content]]
fun _ [] = []
    fun switch :: Bool
switch (Elem e :: Element
e : conts :: [Content]
conts) | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
prefix Text
name Element
e =
                                      if Bool
switch
                                      then (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
newKids [Content] -> [[Content]] -> [[Content]]
forall a. a -> [a] -> [a]
: Bool -> [Content] -> [[Content]]
fun Bool
False [Content]
conts
                                      else Bool -> [Content] -> [[Content]]
fun Bool
False [Content]
conts
    fun switch :: Bool
switch (cont :: Content
cont : conts :: [Content]
conts) = [Content
cont] [Content] -> [[Content]] -> [[Content]]
forall a. a -> [a] -> [a]
: Bool -> [Content] -> [[Content]]
fun Bool
switch [Content]
conts

----------------------------------------------------------------

registerLink :: PandocMonad m => LinkTarget -> P m Int
registerLink :: LinkTarget -> P m Int
registerLink link :: LinkTarget
link = do
  Int
curSlideId <- (WriterEnv -> Int) -> P m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId
  Map Int (Map Int LinkTarget)
linkReg <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
     WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
  Map Int [MediaInfo]
mediaReg <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
  Bool
hasSpeakerNotes <- P m Bool
forall (m :: * -> *). PandocMonad m => P m Bool
curSlideHasSpeakerNotes
  let maxLinkId :: Int
maxLinkId = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg Maybe (Map Int LinkTarget)
-> (Map Int LinkTarget -> Maybe (NonEmpty Int))
-> Maybe (NonEmpty Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int] -> Maybe (NonEmpty Int))
-> (Map Int LinkTarget -> [Int])
-> Map Int LinkTarget
-> Maybe (NonEmpty Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int LinkTarget -> [Int]
forall k a. Map k a -> [k]
M.keys of
        Just xs :: NonEmpty Int
xs -> NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty Int
xs
        Nothing
          | Bool
hasSpeakerNotes -> 2
          | Bool
otherwise       -> 1
      maxMediaId :: Int
maxMediaId = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg Maybe [MediaInfo]
-> ([MediaInfo] -> Maybe (NonEmpty MediaInfo))
-> Maybe (NonEmpty MediaInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MediaInfo] -> Maybe (NonEmpty MediaInfo)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty of
        Just mInfos :: NonEmpty MediaInfo
mInfos -> NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ (MediaInfo -> Int) -> NonEmpty MediaInfo -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MediaInfo -> Int
mInfoLocalId NonEmpty MediaInfo
mInfos
        Nothing
          | Bool
hasSpeakerNotes -> 2
          | Bool
otherwise       -> 1
      maxId :: Int
maxId = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxLinkId Int
maxMediaId
      slideLinks :: Map Int LinkTarget
slideLinks = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg of
        Just mp :: Map Int LinkTarget
mp -> Int -> LinkTarget -> Map Int LinkTarget -> Map Int LinkTarget
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) LinkTarget
link Map Int LinkTarget
mp
        Nothing -> Int -> LinkTarget -> Map Int LinkTarget
forall k a. k -> a -> Map k a
M.singleton (Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) LinkTarget
link
  (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
 -> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stLinkIds :: Map Int (Map Int LinkTarget)
stLinkIds = Int
-> Map Int LinkTarget
-> Map Int (Map Int LinkTarget)
-> Map Int (Map Int LinkTarget)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
curSlideId Map Int LinkTarget
slideLinks Map Int (Map Int LinkTarget)
linkReg}
  Int -> P m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> P m Int) -> Int -> P m Int
forall a b. (a -> b) -> a -> b
$ Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
registerMedia :: FilePath -> [ParaElem] -> P m MediaInfo
registerMedia fp :: FilePath
fp caption :: [ParaElem]
caption = do
  Int
curSlideId <- (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId
  Map Int (Map Int LinkTarget)
linkReg <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
     WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
  Map Int [MediaInfo]
mediaReg <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
  Map FilePath Int
globalIds <- (WriterState -> Map FilePath Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map FilePath Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map FilePath Int
stMediaGlobalIds
  Bool
hasSpeakerNotes <- P m Bool
forall (m :: * -> *). PandocMonad m => P m Bool
curSlideHasSpeakerNotes
  let maxLinkId :: Int
maxLinkId = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg Maybe (Map Int LinkTarget)
-> (Map Int LinkTarget -> Maybe (NonEmpty Int))
-> Maybe (NonEmpty Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int] -> Maybe (NonEmpty Int))
-> (Map Int LinkTarget -> [Int])
-> Map Int LinkTarget
-> Maybe (NonEmpty Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int LinkTarget -> [Int]
forall k a. Map k a -> [k]
M.keys of
          Just ks :: NonEmpty Int
ks -> NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty Int
ks
          Nothing
            | Bool
hasSpeakerNotes -> 2
            | Bool
otherwise       -> 1
      maxMediaId :: Int
maxMediaId = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg Maybe [MediaInfo]
-> ([MediaInfo] -> Maybe (NonEmpty MediaInfo))
-> Maybe (NonEmpty MediaInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [MediaInfo] -> Maybe (NonEmpty MediaInfo)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty of
          Just mInfos :: NonEmpty MediaInfo
mInfos -> NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ (MediaInfo -> Int) -> NonEmpty MediaInfo -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MediaInfo -> Int
mInfoLocalId NonEmpty MediaInfo
mInfos
          Nothing
            | Bool
hasSpeakerNotes -> 2
            | Bool
otherwise       -> 1
      maxLocalId :: Int
maxLocalId = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxLinkId Int
maxMediaId

      maxGlobalId :: Int
maxGlobalId = Int -> (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Maybe (NonEmpty Int) -> Int) -> Maybe (NonEmpty Int) -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Int] -> Maybe (NonEmpty Int)) -> [Int] -> Maybe (NonEmpty Int)
forall a b. (a -> b) -> a -> b
$ Map FilePath Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map FilePath Int
globalIds

  (imgBytes :: ByteString
imgBytes, mbMt :: Maybe Text
mbMt) <- Text
-> ReaderT
     WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (Text
 -> ReaderT
      WriterEnv (StateT WriterState m) (ByteString, Maybe Text))
-> Text
-> ReaderT
     WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
fp
  let imgExt :: Maybe Text
imgExt = (Maybe Text
mbMt Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text
extensionFromMimeType Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\x :: Text
x -> Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ "." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x))
               Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
               case ByteString -> Maybe ImageType
imageType ByteString
imgBytes of
                 Just Png  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".png"
                 Just Jpeg -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".jpeg"
                 Just Gif  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".gif"
                 Just Pdf  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".pdf"
                 Just Eps  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".eps"
                 Just Svg  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".svg"
                 Just Emf  -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".emf"
                 Just Tiff -> Text -> Maybe Text
forall a. a -> Maybe a
Just ".tiff"
                 Nothing   -> Maybe Text
forall a. Maybe a
Nothing

  let newGlobalId :: Int
newGlobalId = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int
maxGlobalId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (FilePath -> Map FilePath Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
fp Map FilePath Int
globalIds)

  let newGlobalIds :: Map FilePath Int
newGlobalIds = FilePath -> Int -> Map FilePath Int -> Map FilePath Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
fp Int
newGlobalId Map FilePath Int
globalIds

  let mediaInfo :: MediaInfo
mediaInfo = MediaInfo :: FilePath
-> Int -> Int -> Maybe Text -> Maybe Text -> Bool -> MediaInfo
MediaInfo { mInfoFilePath :: FilePath
mInfoFilePath = FilePath
fp
                            , mInfoLocalId :: Int
mInfoLocalId = Int
maxLocalId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                            , mInfoGlobalId :: Int
mInfoGlobalId = Int
newGlobalId
                            , mInfoMimeType :: Maybe Text
mInfoMimeType = Maybe Text
mbMt
                            , mInfoExt :: Maybe Text
mInfoExt = Maybe Text
imgExt
                            , mInfoCaption :: Bool
mInfoCaption = (Bool -> Bool
not (Bool -> Bool) -> ([ParaElem] -> Bool) -> [ParaElem] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [ParaElem]
caption
                            }

  let slideMediaInfos :: [MediaInfo]
slideMediaInfos = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg of
        Just minfos :: [MediaInfo]
minfos -> MediaInfo
mediaInfo MediaInfo -> [MediaInfo] -> [MediaInfo]
forall a. a -> [a] -> [a]
: [MediaInfo]
minfos
        Nothing     -> [MediaInfo
mediaInfo]


  (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
 -> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stMediaIds :: Map Int [MediaInfo]
stMediaIds = Int -> [MediaInfo] -> Map Int [MediaInfo] -> Map Int [MediaInfo]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
curSlideId [MediaInfo]
slideMediaInfos Map Int [MediaInfo]
mediaReg
                    , stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Map FilePath Int
newGlobalIds
                    }
  MediaInfo -> P m MediaInfo
forall (m :: * -> *) a. Monad m => a -> m a
return MediaInfo
mediaInfo

makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
makeMediaEntry :: MediaInfo -> P m Entry
makeMediaEntry mInfo :: MediaInfo
mInfo = do
  Pixels
epochtime <- POSIXTime -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Pixels)
-> (UTCTime -> POSIXTime) -> UTCTime -> Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> Pixels)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
-> ReaderT WriterEnv (StateT WriterState m) Pixels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
  (imgBytes :: ByteString
imgBytes, _) <- Text
-> ReaderT
     WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo)
  let ext :: Text
ext = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (MediaInfo -> Maybe Text
mInfoExt MediaInfo
mInfo)
  let fp :: FilePath
fp = "ppt/media/image" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Int -> FilePath
forall a. Show a => a -> FilePath
show (MediaInfo -> Int
mInfoGlobalId MediaInfo
mInfo) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
ext
  Entry -> P m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> P m Entry) -> Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Pixels -> ByteString -> Entry
toEntry FilePath
fp Pixels
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
imgBytes

makeMediaEntries :: PandocMonad m => P m [Entry]
makeMediaEntries :: P m [Entry]
makeMediaEntries = do
  Map Int [MediaInfo]
mediaInfos <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
  let allInfos :: [MediaInfo]
allInfos = [[MediaInfo]] -> [MediaInfo]
forall a. Monoid a => [a] -> a
mconcat ([[MediaInfo]] -> [MediaInfo]) -> [[MediaInfo]] -> [MediaInfo]
forall a b. (a -> b) -> a -> b
$ Map Int [MediaInfo] -> [[MediaInfo]]
forall k a. Map k a -> [a]
M.elems Map Int [MediaInfo]
mediaInfos
  (MediaInfo -> ReaderT WriterEnv (StateT WriterState m) Entry)
-> [MediaInfo] -> P m [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MediaInfo -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *). PandocMonad m => MediaInfo -> P m Entry
makeMediaEntry [MediaInfo]
allInfos

-- -- | Scales the image to fit the page
-- -- sizes are passed in emu
-- fitToPage' :: (Double, Double)  -- image size in emu
--            -> Integer           -- pageWidth
--            -> Integer           -- pageHeight
--            -> (Integer, Integer) -- imagesize
-- fitToPage' (x, y) pageWidth pageHeight
--   -- Fixes width to the page width and scales the height
--   | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =
--       (floor x, floor y)
--   | x / fromIntegral pageWidth > y / fromIntegral pageWidth =
--       (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)
--   | otherwise =
--       (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)

-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)
-- positionImage (x, y) pageWidth pageHeight =
--   let (x', y') = fitToPage' (x, y) pageWidth pageHeight
--   in
--     ((pageWidth - x') `div` 2, (pageHeight - y') `div`  2)

getMaster :: PandocMonad m => P m Element
getMaster :: P m Element
getMaster = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Archive -> Archive -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m Element
getMaster' Archive
refArchive Archive
distArchive

getMaster' :: PandocMonad m => Archive -> Archive -> m Element
getMaster' :: Archive -> Archive -> m Element
getMaster' refArchive :: Archive
refArchive distArchive :: Archive
distArchive =
  Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/slideMasters/slideMaster1.xml"

getMasterRels :: PandocMonad m => P m Element
getMasterRels :: P m Element
getMasterRels = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/slideMasters/_rels/slideMaster1.xml.rels"

-- We want to get the header dimensions, so we can make sure that the
-- image goes underneath it. We only use this in a content slide if it
-- has a header.

-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))
-- getHeaderSize = do
--   master <- getMaster
--   let ns = elemToNameSpaces master
--       sps = [master] >>=
--             findChildren (elemName ns "p" "cSld") >>=
--             findChildren (elemName ns "p" "spTree") >>=
--             findChildren (elemName ns "p" "sp")
--       mbXfrm =
--         listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=
--         findChild (elemName ns "p" "spPr") >>=
--         findChild (elemName ns "a" "xfrm")
--       xoff = mbXfrm >>=
--              findChild (elemName ns "a" "off") >>=
--              findAttr (QName "x" Nothing Nothing) >>=
--              (listToMaybe . (\s -> reads s :: [(Integer, String)]))
--       yoff = mbXfrm >>=
--              findChild (elemName ns "a" "off") >>=
--              findAttr (QName "y" Nothing Nothing) >>=
--              (listToMaybe . (\s -> reads s :: [(Integer, String)]))
--       xext = mbXfrm >>=
--              findChild (elemName ns "a" "ext") >>=
--              findAttr (QName "cx" Nothing Nothing) >>=
--              (listToMaybe . (\s -> reads s :: [(Integer, String)]))
--       yext = mbXfrm >>=
--              findChild (elemName ns "a" "ext") >>=
--              findAttr (QName "cy" Nothing Nothing) >>=
--              (listToMaybe . (\s -> reads s :: [(Integer, String)]))
--       off = case xoff of
--               Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')
--               _                               -> (1043490, 1027664)
--       ext = case xext of
--               Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')
--               _                               -> (7024744, 1143000)
--   return $ (off, ext)

-- Hard-coded for now
-- captionPosition :: ((Integer, Integer), (Integer, Integer))
-- captionPosition = ((457200, 6061972), (8229600, 527087))

captionHeight :: Integer
captionHeight :: Pixels
captionHeight = 40

createCaption :: PandocMonad m
              => ((Integer, Integer), (Integer, Integer))
              -> [ParaElem]
              -> P m (ShapeId, Element)
createCaption :: ((Pixels, Pixels), (Pixels, Pixels))
-> [ParaElem] -> P m (Pixels, Element)
createCaption contentShapeDimensions :: ((Pixels, Pixels), (Pixels, Pixels))
contentShapeDimensions paraElements :: [ParaElem]
paraElements = do
  let para :: Paragraph
para = ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def{pPropAlign :: Maybe Algnment
pPropAlign = Algnment -> Maybe Algnment
forall a. a -> Maybe a
Just Algnment
AlgnCenter} [ParaElem]
paraElements
  [Element]
elements <- (Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph
para]
  let ((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cy :: Pixels
cy)) = ((Pixels, Pixels), (Pixels, Pixels))
contentShapeDimensions
  let txBody :: Element
txBody = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
               [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
  (Pixels, Element) -> P m (Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( 1
    ,  Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvSpPr" []
                          [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
                          , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" [("txBox", "1")] ()
                          , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()
                          ]
                        , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" []
                          [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:xfrm" []
                            [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:off" [("x", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
x),
                                              ("y", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* (Pixels
y Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
+ Pixels
cy Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight))] ()
                            , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cx),
                                              ("cy", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
captionHeight)] ()
                            ]
                          , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:prstGeom" [("prst", "rect")]
                            [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:avLst" [] ()
                            ]
                          , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:noFill" [] ()
                          ]
                        , Element
txBody
                        ]
    )

makePicElements :: PandocMonad m
                => Element
                -> PicProps
                -> MediaInfo
                -> Text
                -> [ParaElem]
                -> P m [(ShapeId, Element)]
makePicElements :: Element
-> PicProps
-> MediaInfo
-> Text
-> [ParaElem]
-> P m [(Pixels, Element)]
makePicElements layout :: Element
layout picProps :: PicProps
picProps mInfo :: MediaInfo
mInfo titleText :: Text
titleText alt :: [ParaElem]
alt = do
  WriterOptions
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOpts
  (pageWidth :: Pixels
pageWidth, pageHeight :: Pixels
pageHeight) <- (WriterEnv -> (Pixels, Pixels))
-> ReaderT WriterEnv (StateT WriterState m) (Pixels, Pixels)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> (Pixels, Pixels)
envPresentationSize
  -- hasHeader <- asks envSlideHasHeader
  let hasCaption :: Bool
hasCaption = MediaInfo -> Bool
mInfoCaption MediaInfo
mInfo
  (imgBytes :: ByteString
imgBytes, _) <- Text
-> ReaderT
     WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo)
  let (pxX :: Pixels
pxX, pxY :: Pixels
pxY) = case WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
imgBytes of
        Right sz :: ImageSize
sz -> ImageSize -> (Pixels, Pixels)
sizeInPixels ImageSize
sz
        Left _   -> ImageSize -> (Pixels, Pixels)
sizeInPixels ImageSize
forall a. Default a => a
def
  Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMaster
  let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
layout
  ((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cytmp :: Pixels
cytmp)) <- NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *).
PandocMonad m =>
NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize NameSpaces
ns Element
layout Element
master
                           P m ((Pixels, Pixels), (Pixels, Pixels))
-> (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
                           (\_ -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((0, 0), (Pixels
pageWidth, Pixels
pageHeight)))

  let cy :: Pixels
cy = if Bool
hasCaption then Pixels
cytmp Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight else Pixels
cytmp

  let imgRatio :: Double
imgRatio = Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
pxX Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
pxY :: Double
      boxRatio :: Double
boxRatio = Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy :: Double
      (dimX :: Double
dimX, dimY :: Double
dimY) = if Double
imgRatio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
boxRatio
                     then (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx, Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
imgRatio)
                     else (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
imgRatio, Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy)

      (dimX' :: Pixels
dimX', dimY' :: Pixels
dimY') = (Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dimX Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700, Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dimY Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700) :: (Integer, Integer)
      (xoff :: Double
xoff, yoff :: Double
yoff) = (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dimX) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2,
                      Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dimY) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2)
      (xoff' :: Pixels
xoff', yoff' :: Pixels
yoff') = (Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
xoff Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700, Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
yoff Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700) :: (Integer, Integer)

  let cNvPicPr :: Element
cNvPicPr = Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPicPr" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                 Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:picLocks" [("noGrp","1")
                                     ,("noChangeAspect","1")] ()
  -- cNvPr will contain the link information so we do that separately,
  -- and register the link if necessary.
  let description :: Text
description = (if Text -> Bool
T.null Text
titleText
                      then ""
                      else Text
titleText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n\n")
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo)
  let cNvPrAttr :: NameSpaces
cNvPrAttr = [("descr", Text
description),
                   ("id","0"),
                   ("name","Picture 1")]
  Element
cNvPr <- case PicProps -> Maybe LinkTarget
picPropLink PicProps
picProps of
    Just link :: LinkTarget
link -> do Int
idNum <- LinkTarget -> P m Int
forall (m :: * -> *). PandocMonad m => LinkTarget -> P m Int
registerLink LinkTarget
link
                    Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" NameSpaces
cNvPrAttr (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                      Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:hlinkClick" [("r:id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
idNum)] ()
    Nothing   -> Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" NameSpaces
cNvPrAttr ()
  let nvPicPr :: Element
nvPicPr  = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPicPr" []
                 [ Element
cNvPr
                 , Element
cNvPicPr
                 , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()]
  let blipFill :: Element
blipFill = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:blipFill" []
                 [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:blip" [("r:embed", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                     Int -> Text
forall a. Show a => a -> Text
tshow (MediaInfo -> Int
mInfoLocalId MediaInfo
mInfo))] ()
                 , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:stretch" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                   Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:fillRect" [] () ]
  let xfrm :: Element
xfrm =    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:xfrm" []
                [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:off" [("x", Pixels -> Text
forall a. Show a => a -> Text
tshow Pixels
xoff'), ("y", Pixels -> Text
forall a. Show a => a -> Text
tshow Pixels
yoff')] ()
                , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", Pixels -> Text
forall a. Show a => a -> Text
tshow Pixels
dimX')
                                 ,("cy", Pixels -> Text
forall a. Show a => a -> Text
tshow Pixels
dimY')] () ]
  let prstGeom :: Element
prstGeom = Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:prstGeom" [("prst","rect")] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                 Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:avLst" [] ()
  let ln :: Element
ln =      Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:ln" [("w","9525")]
                [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:noFill" [] ()
                , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:headEnd" [] ()
                , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tailEnd" [] () ]
  let spPr :: Element
spPr =    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" [("bwMode","auto")]
                [Element
xfrm, Element
prstGeom, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:noFill" [] (), Element
ln]

  let picShape :: (Pixels, Element)
picShape = ( 0
                 , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:pic" []
                   [ Element
nvPicPr
                   , Element
blipFill
                   , Element
spPr ]
                 )

  -- And now, maybe create the caption:
  if Bool
hasCaption
    then do (Pixels, Element)
cap <- ((Pixels, Pixels), (Pixels, Pixels))
-> [ParaElem] -> P m (Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
((Pixels, Pixels), (Pixels, Pixels))
-> [ParaElem] -> P m (Pixels, Element)
createCaption ((Pixels
x, Pixels
y), (Pixels
cx, Pixels
cytmp)) [ParaElem]
alt
            [(Pixels, Element)] -> P m [(Pixels, Element)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pixels, Element)
picShape, (Pixels, Element)
cap]
    else [(Pixels, Element)] -> P m [(Pixels, Element)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pixels, Element)
picShape]

consolidateRuns :: [ParaElem] -> [ParaElem]
consolidateRuns :: [ParaElem] -> [ParaElem]
consolidateRuns [] = []
consolidateRuns (Run pr1 :: RunProps
pr1 s1 :: Text
s1 : Run pr2 :: RunProps
pr2 s2 :: Text
s2 : xs :: [ParaElem]
xs)
  | RunProps
pr1 RunProps -> RunProps -> Bool
forall a. Eq a => a -> a -> Bool
== RunProps
pr2 = [ParaElem] -> [ParaElem]
consolidateRuns (RunProps -> Text -> ParaElem
Run RunProps
pr1 (Text
s1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s2) ParaElem -> [ParaElem] -> [ParaElem]
forall a. a -> [a] -> [a]
: [ParaElem]
xs)
consolidateRuns (x :: ParaElem
x:xs :: [ParaElem]
xs) = ParaElem
x ParaElem -> [ParaElem] -> [ParaElem]
forall a. a -> [a] -> [a]
: [ParaElem] -> [ParaElem]
consolidateRuns [ParaElem]
xs


paraElemToElements :: PandocMonad m => ParaElem -> P m [Content]
paraElemToElements :: ParaElem -> P m [Content]
paraElemToElements Break = [Content] -> P m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:br" [] ()]
paraElemToElements (Run rpr :: RunProps
rpr s :: Text
s) = do
  NameSpaces
sizeAttrs <- RunProps -> P m NameSpaces
forall (m :: * -> *). Monad m => RunProps -> P m NameSpaces
fontSizeAttributes RunProps
rpr
  let attrs :: NameSpaces
attrs = NameSpaces
sizeAttrs NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (
        [("b", "1") | RunProps -> Bool
rPropBold RunProps
rpr]) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (
        [("i", "1") | RunProps -> Bool
rPropItalics RunProps
rpr]) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (
        [("u", "sng") | RunProps -> Bool
rPropUnderline RunProps
rpr]) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (case RunProps -> Maybe Strikethrough
rStrikethrough RunProps
rpr of
            Just NoStrike     -> [("strike", "noStrike")]
            Just SingleStrike -> [("strike", "sngStrike")]
            Just DoubleStrike -> [("strike", "dblStrike")]
            Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (case RunProps -> Maybe Int
rBaseline RunProps
rpr of
            Just n :: Int
n -> [("baseline", Int -> Text
forall a. Show a => a -> Text
tshow Int
n)]
            Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        (case RunProps -> Maybe Capitals
rCap RunProps
rpr of
            Just NoCapitals -> [("cap", "none")]
            Just SmallCapitals -> [("cap", "small")]
            Just AllCapitals -> [("cap", "all")]
            Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
        []
  [Element]
linkProps <- case RunProps -> Maybe LinkTarget
rLink RunProps
rpr of
                 Just link :: LinkTarget
link -> do
                   Int
idNum <- LinkTarget -> P m Int
forall (m :: * -> *). PandocMonad m => LinkTarget -> P m Int
registerLink LinkTarget
link
                   -- first we have to make sure that if it's an
                   -- anchor, it's in the anchor map. If not, there's
                   -- no link.
                   [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall a b. (a -> b) -> a -> b
$ case LinkTarget
link of
                     InternalTarget _ ->
                       let linkAttrs :: NameSpaces
linkAttrs =
                             [ ("r:id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
idNum)
                             , ("action", "ppaction://hlinksldjump")
                             ]
                       in [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:hlinkClick" NameSpaces
linkAttrs ()]
                     -- external
                     ExternalTarget _ ->
                       let linkAttrs :: NameSpaces
linkAttrs =
                             [ ("r:id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
idNum)
                             ]
                       in [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:hlinkClick" NameSpaces
linkAttrs ()]
                 Nothing -> [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  let colorContents :: [Element]
colorContents = case RunProps -> Maybe Color
rSolidFill RunProps
rpr of
                        Just color :: Color
color ->
                          case Color -> FilePath
forall a. FromColor a => Color -> a
fromColor Color
color of
                            '#':hx :: FilePath
hx ->
                              [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:solidFill" []
                                [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:srgbClr"
                                  [("val", Text -> Text
T.toUpper (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
hx)] ()]]
                            _ -> []
                        Nothing -> []
  Text
codeFont <- P m Text
forall (m :: * -> *). Monad m => P m Text
monospaceFont
  let codeContents :: [Element]
codeContents =
        [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:latin" [("typeface", Text
codeFont)] () | RunProps -> Bool
rPropCode RunProps
rpr]
  let propContents :: [Element]
propContents = [Element]
linkProps [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
colorContents [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
codeContents
  [Content] -> P m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:r" [] [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:rPr" NameSpaces
attrs [Element]
propContents
                                 , Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:t" [] Text
s
                                 ]]
paraElemToElements (MathElem mathType :: MathType
mathType texStr :: TeXString
texStr) = do
  Bool
isInSpkrNotes <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInSpeakerNotes
  if Bool
isInSpkrNotes
    then ParaElem -> P m [Content]
forall (m :: * -> *). PandocMonad m => ParaElem -> P m [Content]
paraElemToElements (ParaElem -> P m [Content]) -> ParaElem -> P m [Content]
forall a b. (a -> b) -> a -> b
$ RunProps -> Text -> ParaElem
Run RunProps
forall a. Default a => a
def (Text -> ParaElem) -> Text -> ParaElem
forall a b. (a -> b) -> a -> b
$ TeXString -> Text
unTeXString TeXString
texStr
    else do Either Inline Element
res <- (DisplayType -> [Exp] -> Element)
-> MathType
-> Text
-> ReaderT WriterEnv (StateT WriterState m) (Either Inline Element)
forall (m :: * -> *) a.
PandocMonad m =>
(DisplayType -> [Exp] -> a)
-> MathType -> Text -> m (Either Inline a)
convertMath DisplayType -> [Exp] -> Element
writeOMML MathType
mathType (TeXString -> Text
unTeXString TeXString
texStr)
            case Element -> Element
fromXLElement (Element -> Element)
-> Either Inline Element -> Either Inline Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Inline Element
res of
              Right r :: Element
r -> [Content] -> P m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a14:m" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Element -> Element
addMathInfo Element
r]
              Left (Str s :: Text
s) -> ParaElem -> P m [Content]
forall (m :: * -> *). PandocMonad m => ParaElem -> P m [Content]
paraElemToElements (RunProps -> Text -> ParaElem
Run RunProps
forall a. Default a => a
def Text
s)
              Left _       -> PandocError -> P m [Content]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m [Content]) -> PandocError -> P m [Content]
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocShouldNeverHappenError "non-string math fallback"
paraElemToElements (RawOOXMLParaElem str :: Text
str) = [Content] -> P m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return
  [CData -> Content
Text (CDataKind -> Text -> Maybe Pixels -> CData
CData CDataKind
CDataRaw Text
str Maybe Pixels
forall a. Maybe a
Nothing)]


-- This is a bit of a kludge -- really requires adding an option to
-- TeXMath, but since that's a different package, we'll do this one
-- step at a time.
addMathInfo :: Element -> Element
addMathInfo :: Element -> Element
addMathInfo element :: Element
element =
  let mathspace :: Attr
mathspace =
        Attr :: QName -> Text -> Attr
Attr { attrKey :: QName
attrKey = Text -> Maybe Text -> Maybe Text -> QName
QName "m" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just "xmlns")
             , attrVal :: Text
attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
             }
  in Attr -> Element -> Element
add_attr Attr
mathspace Element
element

-- We look through the element to see if it contains an a14:m
-- element. If so, we surround it. This is a bit ugly, but it seems
-- more dependable than looking through shapes for math. Plus this is
-- an xml implementation detail, so it seems to make sense to do it at
-- the xml level.
surroundWithMathAlternate :: Element -> Element
surroundWithMathAlternate :: Element -> Element
surroundWithMathAlternate element :: Element
element =
  case QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "m" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just "a14")) Element
element of
    Just _ ->
      Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "mc:AlternateContent"
         [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
         ] [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "mc:Choice"
             [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
             , ("Requires", "a14")] [ Element
element ]
           ]
    Nothing -> Element
element

paragraphToElement :: PandocMonad m => Paragraph -> P m Element
paragraphToElement :: Paragraph -> P m Element
paragraphToElement par :: Paragraph
par = do
  Maybe Indents
indents <- (WriterEnv -> Maybe Indents)
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Indents)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Maybe Indents
envOtherStyleIndents
  let
    lvl :: Int
lvl = ParaProps -> Int
pPropLevel (Paragraph -> ParaProps
paraProps Paragraph
par)
    attrs :: NameSpaces
attrs = [("lvl", Int -> Text
forall a. Show a => a -> Text
tshow Int
lvl)] NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
            (case (ParaProps -> Maybe Pixels
pPropIndent (Paragraph -> ParaProps
paraProps Paragraph
par), ParaProps -> Maybe Pixels
pPropMarginLeft (Paragraph -> ParaProps
paraProps Paragraph
par)) of
               (Just px1 :: Pixels
px1, Just px2 :: Pixels
px2) -> [ ("indent", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px1)
                                       , ("marL", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px2)
                                       ]
               (Just px1 :: Pixels
px1, Nothing) -> [("indent", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px1)]
               (Nothing, Just px2 :: Pixels
px2) -> [("marL", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px2)]
               (Nothing, Nothing) -> NameSpaces -> Maybe NameSpaces -> NameSpaces
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe NameSpaces -> NameSpaces) -> Maybe NameSpaces -> NameSpaces
forall a b. (a -> b) -> a -> b
$ do
                 Indents
indents' <- Maybe Indents
indents
                 LevelIndents
thisLevel <- Indents -> Int -> Maybe LevelIndents
levelIndent Indents
indents' Int
lvl
                 LevelIndents
nextLevel <- Indents -> Int -> Maybe LevelIndents
levelIndent Indents
indents' (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
                 let (m :: Maybe Pixels
m, i :: Maybe Pixels
i) =
                       case ParaProps -> Maybe BulletType
pPropBullet (Paragraph -> ParaProps
paraProps Paragraph
par) of
                         Nothing ->
                           (Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just (LevelIndents -> Pixels
marL LevelIndents
thisLevel), Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just 0)
                         Just (AutoNumbering _) ->
                           ( Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just (LevelIndents -> Pixels
marL LevelIndents
nextLevel)
                           , Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just (LevelIndents -> Pixels
marL LevelIndents
thisLevel Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- LevelIndents -> Pixels
marL LevelIndents
nextLevel)
                           )
                         Just Bullet -> (Maybe Pixels
forall a. Maybe a
Nothing, Maybe Pixels
forall a. Maybe a
Nothing)
                 NameSpaces -> Maybe NameSpaces
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Maybe (Text, Text) -> NameSpaces
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((,) "indent" (Text -> (Text, Text))
-> (Pixels -> Text) -> Pixels -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> (Text, Text)) -> Maybe Pixels -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pixels
i)
                      NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<> Maybe (Text, Text) -> NameSpaces
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((,) "marL" (Text -> (Text, Text))
-> (Pixels -> Text) -> Pixels -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> (Text, Text)) -> Maybe Pixels -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Pixels
m)
                      )
            ) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
            (case ParaProps -> Maybe Algnment
pPropAlign (Paragraph -> ParaProps
paraProps Paragraph
par) of
               Just AlgnLeft -> [("algn", "l")]
               Just AlgnRight -> [("algn", "r")]
               Just AlgnCenter -> [("algn", "ctr")]
               Nothing -> []
            )
    props :: [Element]
props = [] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
            (case ParaProps -> Maybe Pixels
pPropSpaceBefore (ParaProps -> Maybe Pixels) -> ParaProps -> Maybe Pixels
forall a b. (a -> b) -> a -> b
$ Paragraph -> ParaProps
paraProps Paragraph
par of
               Just px :: Pixels
px -> [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:spcBef" [] [
                              Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:spcPts" [("val", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 100 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
px)] ()
                              ]
                          ]
               Nothing -> []
            ) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
            (case ParaProps -> Maybe BulletType
pPropBullet (ParaProps -> Maybe BulletType) -> ParaProps -> Maybe BulletType
forall a b. (a -> b) -> a -> b
$ Paragraph -> ParaProps
paraProps Paragraph
par of
               Just Bullet -> []
               Just (AutoNumbering attrs' :: ListAttributes
attrs') ->
                 [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:buAutoNum" (ListAttributes -> NameSpaces
autoNumAttrs ListAttributes
attrs') ()]
               Nothing -> [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:buNone" [] ()]
            )
  [Content]
paras <- [[Content]] -> [Content]
forall a. Monoid a => [a] -> a
mconcat ([[Content]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParaElem -> ReaderT WriterEnv (StateT WriterState m) [Content])
-> [ParaElem]
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParaElem -> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *). PandocMonad m => ParaElem -> P m [Content]
paraElemToElements ([ParaElem] -> [ParaElem]
consolidateRuns (Paragraph -> [ParaElem]
paraElems Paragraph
par))
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Content] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:p" [] ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:pPr" NameSpaces
attrs [Element]
props] [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
paras

shapeToElement :: PandocMonad m => Element -> Shape -> P m (Maybe ShapeId, Element)
shapeToElement :: Element -> Shape -> P m (Maybe Pixels, Element)
shapeToElement layout :: Element
layout (TextBox paras :: [Paragraph]
paras)
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (shapeId :: Maybe Pixels
shapeId, sp :: Element
sp) <- NameSpaces -> Element -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
NameSpaces -> Element -> P m (Maybe Pixels, Element)
getContentShape NameSpaces
ns Element
spTree
      [Element]
elements <- (Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph]
paras
      let txBody :: Element
txBody = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
                   [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
          emptySpPr :: Element
emptySpPr = Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
      (Maybe Pixels, Element) -> P m (Maybe Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe Pixels, Element) -> P m (Maybe Pixels, Element))
-> (Element -> (Maybe Pixels, Element))
-> Element
-> P m (Maybe Pixels, Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Pixels
shapeId,)
        (Element -> (Maybe Pixels, Element))
-> (Element -> Element) -> Element -> (Maybe Pixels, Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
surroundWithMathAlternate
        (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Text -> Text -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "txBody" [Element
txBody]
        (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Text -> Text -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "spPr" [Element
emptySpPr]
        (Element -> P m (Maybe Pixels, Element))
-> Element -> P m (Maybe Pixels, Element)
forall a b. (a -> b) -> a -> b
$ Element
sp
-- GraphicFrame and Pic should never reach this.
shapeToElement _ _ = (Maybe Pixels, Element) -> P m (Maybe Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pixels
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

shapeToElements :: PandocMonad m => Element -> Shape -> P m [(Maybe ShapeId, Content)]
shapeToElements :: Element -> Shape -> P m [(Maybe Pixels, Content)]
shapeToElements layout :: Element
layout (Pic picProps :: PicProps
picProps fp :: FilePath
fp titleText :: Text
titleText alt :: [ParaElem]
alt) = do
  MediaInfo
mInfo <- FilePath -> [ParaElem] -> P m MediaInfo
forall (m :: * -> *).
PandocMonad m =>
FilePath -> [ParaElem] -> P m MediaInfo
registerMedia FilePath
fp [ParaElem]
alt
  case MediaInfo -> Maybe Text
mInfoExt MediaInfo
mInfo of
    Just _ -> ((Pixels, Element) -> (Maybe Pixels, Content))
-> [(Pixels, Element)] -> [(Maybe Pixels, Content)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pixels -> Maybe Pixels)
-> (Element -> Content)
-> (Pixels, Element)
-> (Maybe Pixels, Content)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just Element -> Content
Elem) ([(Pixels, Element)] -> [(Maybe Pixels, Content)])
-> ReaderT WriterEnv (StateT WriterState m) [(Pixels, Element)]
-> P m [(Maybe Pixels, Content)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Element
-> PicProps
-> MediaInfo
-> Text
-> [ParaElem]
-> ReaderT WriterEnv (StateT WriterState m) [(Pixels, Element)]
forall (m :: * -> *).
PandocMonad m =>
Element
-> PicProps
-> MediaInfo
-> Text
-> [ParaElem]
-> P m [(Pixels, Element)]
makePicElements Element
layout PicProps
picProps MediaInfo
mInfo Text
titleText [ParaElem]
alt
    Nothing -> Element -> Shape -> P m [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m [(Maybe Pixels, Content)]
shapeToElements Element
layout (Shape -> P m [(Maybe Pixels, Content)])
-> Shape -> P m [(Maybe Pixels, Content)]
forall a b. (a -> b) -> a -> b
$ [Paragraph] -> Shape
TextBox [ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [ParaElem]
alt]
shapeToElements layout :: Element
layout (GraphicFrame tbls :: [Graphic]
tbls cptn :: [ParaElem]
cptn) = ((Pixels, Element) -> (Maybe Pixels, Content))
-> [(Pixels, Element)] -> [(Maybe Pixels, Content)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pixels -> Maybe Pixels)
-> (Element -> Content)
-> (Pixels, Element)
-> (Maybe Pixels, Content)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just Element -> Content
Elem) ([(Pixels, Element)] -> [(Maybe Pixels, Content)])
-> ReaderT WriterEnv (StateT WriterState m) [(Pixels, Element)]
-> P m [(Maybe Pixels, Content)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Element
-> [Graphic]
-> [ParaElem]
-> ReaderT WriterEnv (StateT WriterState m) [(Pixels, Element)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Graphic] -> [ParaElem] -> P m [(Pixels, Element)]
graphicFrameToElements Element
layout [Graphic]
tbls [ParaElem]
cptn
shapeToElements _ (RawOOXMLShape str :: Text
str) = [(Maybe Pixels, Content)] -> P m [(Maybe Pixels, Content)]
forall (m :: * -> *) a. Monad m => a -> m a
return
  [(Maybe Pixels
forall a. Maybe a
Nothing, CData -> Content
Text (CDataKind -> Text -> Maybe Pixels -> CData
CData CDataKind
CDataRaw Text
str Maybe Pixels
forall a. Maybe a
Nothing))]
shapeToElements layout :: Element
layout shp :: Shape
shp = do
  (shapeId :: Maybe Pixels
shapeId, element :: Element
element) <- Element -> Shape -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m (Maybe Pixels, Element)
shapeToElement Element
layout Shape
shp
  [(Maybe Pixels, Content)] -> P m [(Maybe Pixels, Content)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Maybe Pixels
shapeId, Element -> Content
Elem Element
element)]

shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [(Maybe ShapeId, Content)]
shapesToElements :: Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements layout :: Element
layout shps :: [Shape]
shps =
 [[(Maybe Pixels, Content)]] -> [(Maybe Pixels, Content)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Maybe Pixels, Content)]] -> [(Maybe Pixels, Content)])
-> ReaderT
     WriterEnv (StateT WriterState m) [[(Maybe Pixels, Content)]]
-> P m [(Maybe Pixels, Content)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Shape -> P m [(Maybe Pixels, Content)])
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [[(Maybe Pixels, Content)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Element -> Shape -> P m [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m [(Maybe Pixels, Content)]
shapeToElements Element
layout) [Shape]
shps

graphicFrameToElements ::
  PandocMonad m =>
  Element ->
  [Graphic] ->
  [ParaElem] ->
  P m [(ShapeId, Element)]
graphicFrameToElements :: Element -> [Graphic] -> [ParaElem] -> P m [(Pixels, Element)]
graphicFrameToElements layout :: Element
layout tbls :: [Graphic]
tbls caption :: [ParaElem]
caption = do
  -- get the sizing
  Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMaster
  (pageWidth :: Pixels
pageWidth, pageHeight :: Pixels
pageHeight) <- (WriterEnv -> (Pixels, Pixels))
-> ReaderT WriterEnv (StateT WriterState m) (Pixels, Pixels)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> (Pixels, Pixels)
envPresentationSize
  let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
layout
  ((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cytmp :: Pixels
cytmp)) <- NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *).
PandocMonad m =>
NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize NameSpaces
ns Element
layout Element
master
                           P m ((Pixels, Pixels), (Pixels, Pixels))
-> (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
                           (\_ -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((0, 0), (Pixels
pageWidth, Pixels
pageHeight)))

  let cy :: Pixels
cy = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
caption then Pixels
cytmp Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight else Pixels
cytmp

  [Element]
elements <- (Graphic -> P m Element)
-> [Graphic] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pixels -> Graphic -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Pixels -> Graphic -> P m Element
graphicToElement Pixels
cx) [Graphic]
tbls
  let graphicFrameElts :: (Pixels, Element)
graphicFrameElts =
        ( 6
        , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:graphicFrame" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
          [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvGraphicFramePr" []
            [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
            , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvGraphicFramePr" []
              [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
            , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" []
              [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:ph" [("idx", "1")] ()]
            ]
          , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:xfrm" []
            [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:off" [("x", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
x),
                              ("y", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
y)] ()
            , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cx),
                              ("cy", Pixels -> Text
forall a. Show a => a -> Text
tshow (Pixels -> Text) -> Pixels -> Text
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cy)] ()
            ]
          ] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
        )

  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
caption
    then do (Pixels, Element)
capElt <- ((Pixels, Pixels), (Pixels, Pixels))
-> [ParaElem] -> P m (Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
((Pixels, Pixels), (Pixels, Pixels))
-> [ParaElem] -> P m (Pixels, Element)
createCaption ((Pixels
x, Pixels
y), (Pixels
cx, Pixels
cytmp)) [ParaElem]
caption
            [(Pixels, Element)] -> P m [(Pixels, Element)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pixels, Element)
graphicFrameElts, (Pixels, Element)
capElt]
    else [(Pixels, Element)] -> P m [(Pixels, Element)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pixels, Element)
graphicFrameElts]

getDefaultTableStyle :: PandocMonad m => P m (Maybe T.Text)
getDefaultTableStyle :: P m (Maybe Text)
getDefaultTableStyle = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Element
tblStyleLst <- Archive
-> Archive
-> FilePath
-> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/tableStyles.xml"
  Maybe Text -> P m (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> P m (Maybe Text)) -> Maybe Text -> P m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "def" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
tblStyleLst

graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element
graphicToElement :: Pixels -> Graphic -> P m Element
graphicToElement tableWidth :: Pixels
tableWidth (Tbl tblPr :: TableProps
tblPr hdrCells :: [[Paragraph]]
hdrCells rows :: [[[Paragraph]]]
rows) = do
  let colWidths :: [Pixels]
colWidths = if [[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
hdrCells
                  then case [[[Paragraph]]]
rows of
                         r :: [[Paragraph]]
r : _ | Bool -> Bool
not ([[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
r) -> Int -> Pixels -> [Pixels]
forall a. Int -> a -> [a]
replicate ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
r) (Pixels -> [Pixels]) -> Pixels -> [Pixels]
forall a b. (a -> b) -> a -> b
$
                                                 Pixels
tableWidth Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` Int -> Pixels
forall a. Integral a => a -> Pixels
toInteger ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
r)
                         -- satisfy the compiler. This is the same as
                         -- saying that rows is empty, but the compiler
                         -- won't understand that `[]` exhausts the
                         -- alternatives.
                         _ -> []
                  else Int -> Pixels -> [Pixels]
forall a. Int -> a -> [a]
replicate ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
hdrCells) (Pixels -> [Pixels]) -> Pixels -> [Pixels]
forall a b. (a -> b) -> a -> b
$
                       Pixels
tableWidth Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` Int -> Pixels
forall a. Integral a => a -> Pixels
toInteger ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
hdrCells)

  let cellToOpenXML :: [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML paras :: [Paragraph]
paras =
        do [Element]
elements <- (Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph]
paras
           let elements' :: [Element]
elements' = if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
elements
                           then [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:p" [] [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:endParaRPr" [] ()]]
                           else [Element]
elements

           [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return
             [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
               [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] ()
               , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()]
               [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements']
  [[Element]]
headers' <- ([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [[Paragraph]]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
[Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML [[Paragraph]]
hdrCells
  [[[Element]]]
rows' <- ([[Paragraph]]
 -> ReaderT WriterEnv (StateT WriterState m) [[Element]])
-> [[[Paragraph]]]
-> ReaderT WriterEnv (StateT WriterState m) [[[Element]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [[Paragraph]]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
[Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML) [[[Paragraph]]]
rows
  let borderProps :: Element
borderProps = Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tcPr" [] ()
  let emptyCell' :: [Element]
emptyCell' = [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:p" [] [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:pPr" [] ()]]
  let mkcell :: Bool -> [Element] -> Element
mkcell border :: Bool
border contents :: [Element]
contents = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tc" []
                            ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
contents
                               then [Element]
emptyCell'
                               else [Element]
contents) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [ Element
borderProps | Bool
border ]
  let mkrow :: Bool -> [[Element]] -> Element
mkrow border :: Bool
border cells :: [[Element]]
cells = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tr" [("h", "0")] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ([Element] -> Element) -> [[Element]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [Element] -> Element
mkcell Bool
border) [[Element]]
cells

  let mkgridcol :: Pixels -> Element
mkgridcol w :: Pixels
w = Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:gridCol"
                       [("w", Pixels -> Text
forall a. Show a => a -> Text
tshow ((12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
w) :: Integer))] ()
  let hasHeader :: Bool
hasHeader = Bool -> Bool
not (([Paragraph] -> Bool) -> [[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Paragraph] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
hdrCells)

  Maybe Text
mbDefTblStyle <- P m (Maybe Text)
forall (m :: * -> *). PandocMonad m => P m (Maybe Text)
getDefaultTableStyle
  let tblPrElt :: Element
tblPrElt = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tblPr"
                 [ ("firstRow", if TableProps -> Bool
tblPrFirstRow TableProps
tblPr then "1" else "0")
                 , ("bandRow", if TableProps -> Bool
tblPrBandRow TableProps
tblPr then "1" else "0")
                 ] (case Maybe Text
mbDefTblStyle of
                      Nothing -> []
                      Just sty :: Text
sty -> [Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tableStyleId" [] Text
sty])

  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:graphic" []
    [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")]
     [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tbl" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
      [ Element
tblPrElt
      , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:tblGrid" [] (if (Pixels -> Bool) -> [Pixels] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pixels -> Pixels -> Bool
forall a. Eq a => a -> a -> Bool
==0) [Pixels]
colWidths
                               then []
                               else (Pixels -> Element) -> [Pixels] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Pixels -> Element
mkgridcol [Pixels]
colWidths)
      ]
      [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [ Bool -> [[Element]] -> Element
mkrow Bool
True [[Element]]
headers' | Bool
hasHeader ] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> ([[Element]] -> Element) -> [[[Element]]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [[Element]] -> Element
mkrow Bool
False) [[[Element]]]
rows'
     ]
    ]


-- We get the shape by placeholder type. If there is NO type, it
-- defaults to a content placeholder.

data PHType = PHType T.Text | ObjType
  deriving (Int -> PHType -> ShowS
[PHType] -> ShowS
PHType -> FilePath
(Int -> PHType -> ShowS)
-> (PHType -> FilePath) -> ([PHType] -> ShowS) -> Show PHType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PHType] -> ShowS
$cshowList :: [PHType] -> ShowS
show :: PHType -> FilePath
$cshow :: PHType -> FilePath
showsPrec :: Int -> PHType -> ShowS
$cshowsPrec :: Int -> PHType -> ShowS
Show, PHType -> PHType -> Bool
(PHType -> PHType -> Bool)
-> (PHType -> PHType -> Bool) -> Eq PHType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PHType -> PHType -> Bool
$c/= :: PHType -> PHType -> Bool
== :: PHType -> PHType -> Bool
$c== :: PHType -> PHType -> Bool
Eq)

findPHType :: NameSpaces -> Element -> PHType -> Bool
findPHType :: NameSpaces -> Element -> PHType -> Bool
findPHType ns :: NameSpaces
ns spElem :: Element
spElem phType :: PHType
phType
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
spElem =
    let mbPHElem :: Maybe Element
mbPHElem = (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
spElem Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvSpPr") Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvPr") Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "ph"))
    in
      case Maybe Element
mbPHElem of
        -- if it's a named PHType, we want to check that the attribute
        -- value matches.
        Just phElem :: Element
phElem | (PHType tp :: Text
tp) <- PHType
phType ->
                        case QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
phElem of
                          Just tp' :: Text
tp' -> Text
tp Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tp'
                          Nothing -> Bool
False
        -- if it's an ObjType, we want to check that there is NO
        -- "type" attribute. In other words, a lookup should return nothing.
        Just phElem :: Element
phElem | PHType
ObjType <- PHType
phType ->
                        case QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
phElem of
                          Just _ -> Bool
False
                          Nothing -> Bool
True
        Nothing -> Bool
False
findPHType _ _ _ = Bool
False

getShapesByPlaceHolderType :: NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType :: NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem phType :: PHType
phType
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "p" "spTree" Element
spTreeElem =
      (Element -> Bool) -> Element -> [Element]
filterChildren (\e :: Element
e -> NameSpaces -> Element -> PHType -> Bool
findPHType NameSpaces
ns Element
e PHType
phType) Element
spTreeElem
  | Bool
otherwise = []

getShapeByPlaceHolderType :: NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType :: NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem phType :: PHType
phType =
  [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe ([Element] -> Maybe Element) -> [Element] -> Maybe Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
phType

-- Like the above, but it tries a number of different placeholder types
getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes _ _ [] = Maybe Element
forall a. Maybe a
Nothing
getShapeByPlaceHolderTypes ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem (s :: PHType
s:ss :: [PHType]
ss) =
  case NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
s of
    Just element :: Element
element -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
element
    Nothing -> NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes NameSpaces
ns Element
spTreeElem [PHType]
ss

nonBodyTextToElement ::
  PandocMonad m =>
  Element ->
  [PHType] ->
  [ParaElem] ->
  P m (Maybe ShapeId, Element)
nonBodyTextToElement :: Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement layout :: Element
layout phTypes :: [PHType]
phTypes paraElements :: [ParaElem]
paraElements
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
  , Just sp :: Element
sp <- NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes NameSpaces
ns Element
spTree [PHType]
phTypes
  , Just nvSpPr :: Element
nvSpPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
sp
  , Just cNvPr :: Element
cNvPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cNvPr") Element
nvSpPr
  , Just shapeId :: Text
shapeId <- QName -> Element -> Maybe Text
findAttr (Text -> QName
nodename "id") Element
cNvPr
  , Right (shapeIdNum :: Pixels
shapeIdNum, _) <- Text -> Either FilePath (Pixels, Text)
forall a. Integral a => Reader a
decimal Text
shapeId = do
      let hdrPara :: Paragraph
hdrPara = ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [ParaElem]
paraElements
      Element
element <- Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement Paragraph
hdrPara
      let txBody :: Element
txBody = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
                   [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
                   [Element
element]
      (Maybe Pixels, Element) -> P m (Maybe Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixels -> Maybe Pixels
forall a. a -> Maybe a
Just Pixels
shapeIdNum, NameSpaces -> Text -> Text -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "txBody" [Element
txBody] Element
sp)
  -- XXX: TODO
  | Bool
otherwise = (Maybe Pixels, Element) -> P m (Maybe Pixels, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pixels
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

data ContentShapeIds = ContentShapeIds
  { ContentShapeIds -> Maybe Pixels
contentHeaderId :: Maybe ShapeId
  , ContentShapeIds -> [Pixels]
contentContentIds :: [ShapeId]
  }

contentToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  [Shape] ->
  P m (Maybe ContentShapeIds, Element)
contentToElement :: Element
-> [ParaElem] -> [Shape] -> P m (Maybe ContentShapeIds, Element)
contentToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape shapes :: [Shape]
shapes
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (shapeId :: Maybe Pixels
shapeId, element :: Element
element) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "title"] [ParaElem]
hdrShape
      let hdrShapeElements :: [Content]
hdrShapeElements = [Element -> Content
Elem Element
element | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape)]
          contentHeaderId :: Maybe Pixels
contentHeaderId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
shapeId
      [(Maybe Pixels, Content)]
content' <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
                         (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 0})
                         (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapes)
      let contentContentIds :: [Pixels]
contentContentIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
content'
          contentElements :: [Content]
contentElements = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
content'
      [Content]
footer <- (forall a. SlideLayoutsOf a -> a) -> P m [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
content
      (Maybe ContentShapeIds, Element)
-> P m (Maybe ContentShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return ( ContentShapeIds -> Maybe ContentShapeIds
forall a. a -> Maybe a
Just ContentShapeIds :: Maybe Pixels -> [Pixels] -> ContentShapeIds
ContentShapeIds{..}
             , NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Content]
hdrShapeElements [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
contentElements [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer)
             )
contentToElement _ _ _ = (Maybe ContentShapeIds, Element)
-> P m (Maybe ContentShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ContentShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

data TwoColumnShapeIds = TwoColumnShapeIds
  { TwoColumnShapeIds -> Maybe Pixels
twoColumnHeaderId :: Maybe ShapeId
  , TwoColumnShapeIds -> [Pixels]
twoColumnLeftIds :: [ShapeId]
  , TwoColumnShapeIds -> [Pixels]
twoColumnRightIds :: [ShapeId]
  }

twoColumnToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  [Shape] ->
  [Shape] ->
  P m (Maybe TwoColumnShapeIds, Element)
twoColumnToElement :: Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> P m (Maybe TwoColumnShapeIds, Element)
twoColumnToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape shapesL :: [Shape]
shapesL shapesR :: [Shape]
shapesR
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (headerId :: Maybe Pixels
headerId, element :: Element
element) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "title"] [ParaElem]
hdrShape
      let hdrShapeElements :: [Content]
hdrShapeElements = [Element -> Content
Elem Element
element | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape)]
          twoColumnHeaderId :: Maybe Pixels
twoColumnHeaderId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
headerId
      [(Maybe Pixels, Content)]
contentL <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 0})
                        (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesL)
      let twoColumnLeftIds :: [Pixels]
twoColumnLeftIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentL
          contentElementsL :: [Content]
contentElementsL = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentL
      [(Maybe Pixels, Content)]
contentR <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 1})
                        (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesR)
      let ([Pixels]
twoColumnRightIds) = (((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentR)
          contentElementsR :: [Content]
contentElementsR = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentR
      -- let contentElementsL' = map (setIdx ns "1") contentElementsL
      --     contentElementsR' = map (setIdx ns "2") contentElementsR
      [Content]
footer <- (forall a. SlideLayoutsOf a -> a) -> P m [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
twoColumn
      (Maybe TwoColumnShapeIds, Element)
-> P m (Maybe TwoColumnShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe TwoColumnShapeIds, Element)
 -> P m (Maybe TwoColumnShapeIds, Element))
-> (Maybe TwoColumnShapeIds, Element)
-> P m (Maybe TwoColumnShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ (TwoColumnShapeIds -> Maybe TwoColumnShapeIds
forall a. a -> Maybe a
Just TwoColumnShapeIds :: Maybe Pixels -> [Pixels] -> [Pixels] -> TwoColumnShapeIds
TwoColumnShapeIds{..}, )
        (Element -> (Maybe TwoColumnShapeIds, Element))
-> Element -> (Maybe TwoColumnShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree
        ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ [Content]
hdrShapeElements [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
contentElementsL [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
contentElementsR [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer
twoColumnToElement _ _ _ _ = (Maybe TwoColumnShapeIds, Element)
-> P m (Maybe TwoColumnShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TwoColumnShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

data ComparisonShapeIds = ComparisonShapeIds
  { ComparisonShapeIds -> Maybe Pixels
comparisonHeaderId :: Maybe ShapeId
  , ComparisonShapeIds -> [Pixels]
comparisonLeftTextIds :: [ShapeId]
  , ComparisonShapeIds -> [Pixels]
comparisonLeftContentIds :: [ShapeId]
  , ComparisonShapeIds -> [Pixels]
comparisonRightTextIds :: [ShapeId]
  , ComparisonShapeIds -> [Pixels]
comparisonRightContentIds :: [ShapeId]
  }

comparisonToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  ([Shape], [Shape]) ->
  ([Shape], [Shape]) ->
  P m (Maybe ComparisonShapeIds, Element)
comparisonToElement :: Element
-> [ParaElem]
-> ([Shape], [Shape])
-> ([Shape], [Shape])
-> P m (Maybe ComparisonShapeIds, Element)
comparisonToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape (shapesL1 :: [Shape]
shapesL1, shapesL2 :: [Shape]
shapesL2) (shapesR1 :: [Shape]
shapesR1, shapesR2 :: [Shape]
shapesR2)
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (headerShapeId :: Maybe Pixels
headerShapeId, element :: Element
element) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "title"] [ParaElem]
hdrShape
      let hdrShapeElements :: [Content]
hdrShapeElements = [Element -> Content
Elem Element
element | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape)]
          comparisonHeaderId :: Maybe Pixels
comparisonHeaderId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
headerShapeId
      [(Maybe Pixels, Content)]
contentL1 <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder (Text -> PHType
PHType "body") 0})
                         (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesL1)
      let comparisonLeftTextIds :: [Pixels]
comparisonLeftTextIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentL1
          contentElementsL1 :: [Content]
contentElementsL1 = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentL1
      [(Maybe Pixels, Content)]
contentL2 <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 0})
                         (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesL2)
      let comparisonLeftContentIds :: [Pixels]
comparisonLeftContentIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentL2
          contentElementsL2 :: [Content]
contentElementsL2 = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentL2
      [(Maybe Pixels, Content)]
contentR1 <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder (Text -> PHType
PHType "body") 1})
                         (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesR1)
      let comparisonRightTextIds :: [Pixels]
comparisonRightTextIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentR1
          contentElementsR1 :: [Content]
contentElementsR1 = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentR1
      [(Maybe Pixels, Content)]
contentR2 <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 1})
                         (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
shapesR2)
      let comparisonRightContentIds :: [Pixels]
comparisonRightContentIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
contentR2
          contentElementsR2 :: [Content]
contentElementsR2 = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
contentR2
      [Content]
footer <- (forall a. SlideLayoutsOf a -> a) -> P m [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
comparison
      (Maybe ComparisonShapeIds, Element)
-> P m (Maybe ComparisonShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe ComparisonShapeIds, Element)
 -> P m (Maybe ComparisonShapeIds, Element))
-> (Maybe ComparisonShapeIds, Element)
-> P m (Maybe ComparisonShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ (ComparisonShapeIds -> Maybe ComparisonShapeIds
forall a. a -> Maybe a
Just ComparisonShapeIds :: Maybe Pixels
-> [Pixels]
-> [Pixels]
-> [Pixels]
-> [Pixels]
-> ComparisonShapeIds
ComparisonShapeIds{..}, )
        (Element -> (Maybe ComparisonShapeIds, Element))
-> Element -> (Maybe ComparisonShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree
        ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ [[Content]] -> [Content]
forall a. Monoid a => [a] -> a
mconcat [ [Content]
hdrShapeElements
                  , [Content]
contentElementsL1
                  , [Content]
contentElementsL2
                  , [Content]
contentElementsR1
                  , [Content]
contentElementsR2
                  ] [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer
comparisonToElement _ _ _ _= (Maybe ComparisonShapeIds, Element)
-> P m (Maybe ComparisonShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComparisonShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

data ContentWithCaptionShapeIds = ContentWithCaptionShapeIds
  { ContentWithCaptionShapeIds -> Maybe Pixels
contentWithCaptionHeaderId :: Maybe ShapeId
  , ContentWithCaptionShapeIds -> [Pixels]
contentWithCaptionCaptionIds :: [ShapeId]
  , ContentWithCaptionShapeIds -> [Pixels]
contentWithCaptionContentIds :: [ShapeId]
  }

contentWithCaptionToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  [Shape] ->
  [Shape] ->
  P m (Maybe ContentWithCaptionShapeIds, Element)
contentWithCaptionToElement :: Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> P m (Maybe ContentWithCaptionShapeIds, Element)
contentWithCaptionToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape textShapes :: [Shape]
textShapes contentShapes :: [Shape]
contentShapes
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (shapeId :: Maybe Pixels
shapeId, element :: Element
element) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "title"] [ParaElem]
hdrShape
      let hdrShapeElements :: [Content]
hdrShapeElements = [Element -> Content
Elem Element
element | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape)]
          contentWithCaptionHeaderId :: Maybe Pixels
contentWithCaptionHeaderId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
shapeId
      [(Maybe Pixels, Content)]
text <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder (Text -> PHType
PHType "body") 0})
                    (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
textShapes)
      let contentWithCaptionCaptionIds :: [Pixels]
contentWithCaptionCaptionIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
text
          textElements :: [Content]
textElements = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
text
      [(Maybe Pixels, Content)]
content <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envPlaceholder :: Placeholder
envPlaceholder = PHType -> Int -> Placeholder
Placeholder PHType
ObjType 0})
                       (Element
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) [(Maybe Pixels, Content)]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [(Maybe Pixels, Content)]
shapesToElements Element
layout [Shape]
contentShapes)
      let contentWithCaptionContentIds :: [Pixels]
contentWithCaptionContentIds = ((Maybe Pixels, Content) -> Maybe Pixels)
-> [(Maybe Pixels, Content)] -> [Pixels]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe Pixels, Content) -> Maybe Pixels
forall a b. (a, b) -> a
fst [(Maybe Pixels, Content)]
content
          contentElements :: [Content]
contentElements = (Maybe Pixels, Content) -> Content
forall a b. (a, b) -> b
snd ((Maybe Pixels, Content) -> Content)
-> [(Maybe Pixels, Content)] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Pixels, Content)]
content
      [Content]
footer <- (forall a. SlideLayoutsOf a -> a) -> P m [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
contentWithCaption
      (Maybe ContentWithCaptionShapeIds, Element)
-> P m (Maybe ContentWithCaptionShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe ContentWithCaptionShapeIds, Element)
 -> P m (Maybe ContentWithCaptionShapeIds, Element))
-> (Maybe ContentWithCaptionShapeIds, Element)
-> P m (Maybe ContentWithCaptionShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ (ContentWithCaptionShapeIds -> Maybe ContentWithCaptionShapeIds
forall a. a -> Maybe a
Just ContentWithCaptionShapeIds :: Maybe Pixels -> [Pixels] -> [Pixels] -> ContentWithCaptionShapeIds
ContentWithCaptionShapeIds{..}, )
        (Element -> (Maybe ContentWithCaptionShapeIds, Element))
-> Element -> (Maybe ContentWithCaptionShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree
        ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ [[Content]] -> [Content]
forall a. Monoid a => [a] -> a
mconcat [ [Content]
hdrShapeElements
                  , [Content]
textElements
                  , [Content]
contentElements
                  ] [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer
contentWithCaptionToElement _ _ _ _ = (Maybe ContentWithCaptionShapeIds, Element)
-> P m (Maybe ContentWithCaptionShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ContentWithCaptionShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

blankToElement ::
  PandocMonad m =>
  Element ->
  P m Element
blankToElement :: Element -> P m Element
blankToElement layout :: Element
layout
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld =
      NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Content] -> Element)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
-> P m Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. SlideLayoutsOf a -> a)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
blank
blankToElement _ = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ()

newtype TitleShapeIds = TitleShapeIds
  { TitleShapeIds -> Maybe Pixels
titleHeaderId :: Maybe ShapeId
  }

titleToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  P m (Maybe TitleShapeIds, Element)
titleToElement :: Element -> [ParaElem] -> P m (Maybe TitleShapeIds, Element)
titleToElement layout :: Element
layout titleElems :: [ParaElem]
titleElems
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      (shapeId :: Maybe Pixels
shapeId, element :: Element
element) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "title", Text -> PHType
PHType "ctrTitle"] [ParaElem]
titleElems
      let titleShapeElements :: [Content]
titleShapeElements = [Element -> Content
Elem Element
element | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems)]
          titleHeaderId :: Maybe Pixels
titleHeaderId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
shapeId
      [Content]
footer <- (forall a. SlideLayoutsOf a -> a) -> P m [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
title
      (Maybe TitleShapeIds, Element)
-> P m (Maybe TitleShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe TitleShapeIds, Element)
 -> P m (Maybe TitleShapeIds, Element))
-> (Maybe TitleShapeIds, Element)
-> P m (Maybe TitleShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ (TitleShapeIds -> Maybe TitleShapeIds
forall a. a -> Maybe a
Just TitleShapeIds :: Maybe Pixels -> TitleShapeIds
TitleShapeIds{..}, )
        (Element -> (Maybe TitleShapeIds, Element))
-> Element -> (Maybe TitleShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Content]
titleShapeElements [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer)
titleToElement _ _ = (Maybe TitleShapeIds, Element)
-> P m (Maybe TitleShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TitleShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

data MetadataShapeIds = MetadataShapeIds
  { MetadataShapeIds -> Maybe Pixels
metadataTitleId :: Maybe ShapeId
  , MetadataShapeIds -> Maybe Pixels
metadataSubtitleId :: Maybe ShapeId
  , MetadataShapeIds -> Maybe Pixels
metadataDateId :: Maybe ShapeId
  }

metadataToElement ::
  PandocMonad m =>
  Element ->
  [ParaElem] ->
  [ParaElem] ->
  [[ParaElem]] ->
  [ParaElem] ->
  P m (Maybe MetadataShapeIds, Element)
metadataToElement :: Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m (Maybe MetadataShapeIds, Element)
metadataToElement layout :: Element
layout titleElems :: [ParaElem]
titleElems subtitleElems :: [ParaElem]
subtitleElems authorsElems :: [[ParaElem]]
authorsElems dateElems :: [ParaElem]
dateElems
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
      let combinedAuthorElems :: [ParaElem]
combinedAuthorElems = [ParaElem] -> [[ParaElem]] -> [ParaElem]
forall a. [a] -> [[a]] -> [a]
intercalate [ParaElem
Break] [[ParaElem]]
authorsElems
          subtitleAndAuthorElems :: [ParaElem]
subtitleAndAuthorElems = [ParaElem] -> [[ParaElem]] -> [ParaElem]
forall a. [a] -> [[a]] -> [a]
intercalate [ParaElem
Break, ParaElem
Break] [[ParaElem]
subtitleElems, [ParaElem]
combinedAuthorElems]
      (titleId :: Maybe Pixels
titleId, titleElement :: Element
titleElement) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "ctrTitle"] [ParaElem]
titleElems
      (subtitleId :: Maybe Pixels
subtitleId, subtitleElement :: Element
subtitleElement) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "subTitle"] [ParaElem]
subtitleAndAuthorElems
      (dateId :: Maybe Pixels
dateId, dateElement :: Element
dateElement) <- Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m (Maybe Pixels, Element)
nonBodyTextToElement Element
layout [Text -> PHType
PHType "dt"] [ParaElem]
dateElems
      let titleShapeElements :: [Element]
titleShapeElements = [Element
titleElement | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems)]
          metadataTitleId :: Maybe Pixels
metadataTitleId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
titleId
          subtitleShapeElements :: [Element]
subtitleShapeElements = [Element
subtitleElement | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
subtitleAndAuthorElems)]
          metadataSubtitleId :: Maybe Pixels
metadataSubtitleId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
subtitleAndAuthorElems then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
subtitleId
      Maybe FooterInfo
footerInfo <- (WriterState -> Maybe FooterInfo)
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FooterInfo)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Maybe FooterInfo
stFooterInfo
      [Content]
footer <- (if Bool -> (FooterInfo -> Bool) -> Maybe FooterInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FooterInfo -> Bool
fiShowOnFirstSlide Maybe FooterInfo
footerInfo
                 then [Content] -> [Content]
forall a. a -> a
id
                 else [Content] -> [Content] -> [Content]
forall a b. a -> b -> a
const []) ([Content] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. SlideLayoutsOf a -> a)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *).
PandocMonad m =>
(forall a. SlideLayoutsOf a -> a) -> P m [Content]
footerElements forall a. SlideLayoutsOf a -> a
metadata
      let dateShapeElements :: [Element]
dateShapeElements = [Element
dateElement
                              | Bool -> Bool
not ([ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
dateElems
                                Bool -> Bool -> Bool
|| Maybe Element -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FooterInfo
footerInfo Maybe FooterInfo -> (FooterInfo -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SlideLayoutsOf (Maybe Element) -> Maybe Element
forall a. SlideLayoutsOf a -> a
metadata (SlideLayoutsOf (Maybe Element) -> Maybe Element)
-> (FooterInfo -> SlideLayoutsOf (Maybe Element))
-> FooterInfo
-> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FooterInfo -> SlideLayoutsOf (Maybe Element)
fiDate))
                              ]
          metadataDateId :: Maybe Pixels
metadataDateId = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
dateElems then Maybe Pixels
forall a. Maybe a
Nothing else Maybe Pixels
dateId
      (Maybe MetadataShapeIds, Element)
-> P m (Maybe MetadataShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ((Maybe MetadataShapeIds, Element)
 -> P m (Maybe MetadataShapeIds, Element))
-> (Maybe MetadataShapeIds, Element)
-> P m (Maybe MetadataShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ (MetadataShapeIds -> Maybe MetadataShapeIds
forall a. a -> Maybe a
Just MetadataShapeIds :: Maybe Pixels -> Maybe Pixels -> Maybe Pixels -> MetadataShapeIds
MetadataShapeIds{..}, )
        (Element -> (Maybe MetadataShapeIds, Element))
-> Element -> (Maybe MetadataShapeIds, Element)
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Content] -> Element
buildSpTree NameSpaces
ns Element
spTree
        ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$ (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element]
titleShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
subtitleShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
dateShapeElements)
        [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
footer
metadataToElement _ _ _ _ _ = (Maybe MetadataShapeIds, Element)
-> P m (Maybe MetadataShapeIds, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MetadataShapeIds
forall a. Maybe a
Nothing, Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" [] ())

slideToElement :: PandocMonad m => Slide -> P m Element
slideToElement :: Slide -> P m Element
slideToElement (Slide _ l :: Layout
l@(ContentSlide hdrElems :: [ParaElem]
hdrElems shapes :: [Shape]
shapes) _ backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (shapeIds :: Maybe ContentShapeIds
shapeIds, spTree :: Element
spTree)
     <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe ContentShapeIds, Element)
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe ContentShapeIds, Element)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrElems
                       then WriterEnv
env
                       else WriterEnv
env{envSlideHasHeader :: Bool
envSlideHasHeader=Bool
True})
              (Element
-> [ParaElem]
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe ContentShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem] -> [Shape] -> P m (Maybe ContentShapeIds, Element)
contentToElement Element
layout [ParaElem]
hdrElems [Shape]
shapes)
  let animations :: [Element]
animations = case Maybe ContentShapeIds
shapeIds of
        Nothing -> []
        Just ContentShapeIds{..} ->
          [(Pixels, Shape)] -> [Element]
slideToIncrementalAnimations ([Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
contentContentIds [Shape]
shapes)
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] (Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree]) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
animations)
slideToElement (Slide _ l :: Layout
l@(TwoColumnSlide hdrElems :: [ParaElem]
hdrElems shapesL :: [Shape]
shapesL shapesR :: [Shape]
shapesR) _ backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (shapeIds :: Maybe TwoColumnShapeIds
shapeIds, spTree :: Element
spTree) <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrElems
                           then WriterEnv
env
                           else WriterEnv
env{envSlideHasHeader :: Bool
envSlideHasHeader=Bool
True}) (ReaderT
   WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
 -> ReaderT
      WriterEnv
      (StateT WriterState m)
      (Maybe TwoColumnShapeIds, Element))
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
forall a b. (a -> b) -> a -> b
$
            Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> ReaderT
     WriterEnv (StateT WriterState m) (Maybe TwoColumnShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> P m (Maybe TwoColumnShapeIds, Element)
twoColumnToElement Element
layout [ParaElem]
hdrElems [Shape]
shapesL [Shape]
shapesR
  let animations :: [Element]
animations = case Maybe TwoColumnShapeIds
shapeIds of
        Nothing -> []
        Just TwoColumnShapeIds{..} ->
          [(Pixels, Shape)] -> [Element]
slideToIncrementalAnimations ([Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
twoColumnLeftIds [Shape]
shapesL
                                        [(Pixels, Shape)] -> [(Pixels, Shape)] -> [(Pixels, Shape)]
forall a. Semigroup a => a -> a -> a
<> [Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
twoColumnRightIds [Shape]
shapesR)
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] (Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree]) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
animations)
slideToElement (Slide _ l :: Layout
l@(ComparisonSlide hdrElems :: [ParaElem]
hdrElems shapesL :: ([Shape], [Shape])
shapesL shapesR :: ([Shape], [Shape])
shapesR) _ backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (shapeIds :: Maybe ComparisonShapeIds
shapeIds, spTree :: Element
spTree) <- (WriterEnv -> WriterEnv)
-> ReaderT
     WriterEnv
     (StateT WriterState m)
     (Maybe ComparisonShapeIds, Element)
-> ReaderT
     WriterEnv
     (StateT WriterState m)
     (Maybe ComparisonShapeIds, Element)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrElems
                           then WriterEnv
env
                           else WriterEnv
env{envSlideHasHeader :: Bool
envSlideHasHeader=Bool
True}) (ReaderT
   WriterEnv
   (StateT WriterState m)
   (Maybe ComparisonShapeIds, Element)
 -> ReaderT
      WriterEnv
      (StateT WriterState m)
      (Maybe ComparisonShapeIds, Element))
-> ReaderT
     WriterEnv
     (StateT WriterState m)
     (Maybe ComparisonShapeIds, Element)
-> ReaderT
     WriterEnv
     (StateT WriterState m)
     (Maybe ComparisonShapeIds, Element)
forall a b. (a -> b) -> a -> b
$
            Element
-> [ParaElem]
-> ([Shape], [Shape])
-> ([Shape], [Shape])
-> ReaderT
     WriterEnv
     (StateT WriterState m)
     (Maybe ComparisonShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem]
-> ([Shape], [Shape])
-> ([Shape], [Shape])
-> P m (Maybe ComparisonShapeIds, Element)
comparisonToElement Element
layout [ParaElem]
hdrElems ([Shape], [Shape])
shapesL ([Shape], [Shape])
shapesR
  let animations :: [Element]
animations = case Maybe ComparisonShapeIds
shapeIds of
        Nothing -> []
        Just ComparisonShapeIds{..} ->
          [(Pixels, Shape)] -> [Element]
slideToIncrementalAnimations
            ([Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
comparisonLeftTextIds (([Shape], [Shape]) -> [Shape]
forall a b. (a, b) -> a
fst ([Shape], [Shape])
shapesL)
            [(Pixels, Shape)] -> [(Pixels, Shape)] -> [(Pixels, Shape)]
forall a. Semigroup a => a -> a -> a
<> [Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
comparisonLeftContentIds (([Shape], [Shape]) -> [Shape]
forall a b. (a, b) -> b
snd ([Shape], [Shape])
shapesL)
            [(Pixels, Shape)] -> [(Pixels, Shape)] -> [(Pixels, Shape)]
forall a. Semigroup a => a -> a -> a
<> [Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
comparisonRightTextIds (([Shape], [Shape]) -> [Shape]
forall a b. (a, b) -> a
fst ([Shape], [Shape])
shapesR)
            [(Pixels, Shape)] -> [(Pixels, Shape)] -> [(Pixels, Shape)]
forall a. Semigroup a => a -> a -> a
<> [Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
comparisonRightContentIds (([Shape], [Shape]) -> [Shape]
forall a b. (a, b) -> b
snd ([Shape], [Shape])
shapesR))
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] (Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree]) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
animations)
slideToElement (Slide _ l :: Layout
l@(TitleSlide hdrElems :: [ParaElem]
hdrElems) _ backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (_, spTree :: Element
spTree) <- Element -> [ParaElem] -> P m (Maybe TitleShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element -> [ParaElem] -> P m (Maybe TitleShapeIds, Element)
titleToElement Element
layout [ParaElem]
hdrElems
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree])]
slideToElement (Slide
                _
                l :: Layout
l@(MetadataSlide titleElems :: [ParaElem]
titleElems subtitleElems :: [ParaElem]
subtitleElems authorElems :: [[ParaElem]]
authorElems dateElems :: [ParaElem]
dateElems)
                _
                backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (_, spTree :: Element
spTree) <- Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m (Maybe MetadataShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m (Maybe MetadataShapeIds, Element)
metadataToElement Element
layout [ParaElem]
titleElems [ParaElem]
subtitleElems [[ParaElem]]
authorElems [ParaElem]
dateElems
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree])]
slideToElement (Slide
                _
                l :: Layout
l@(ContentWithCaptionSlide hdrElems :: [ParaElem]
hdrElems captionShapes :: [Shape]
captionShapes contentShapes :: [Shape]
contentShapes)
                _
                backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  (shapeIds :: Maybe ContentWithCaptionShapeIds
shapeIds, spTree :: Element
spTree) <- Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> P m (Maybe ContentWithCaptionShapeIds, Element)
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem]
-> [Shape]
-> [Shape]
-> P m (Maybe ContentWithCaptionShapeIds, Element)
contentWithCaptionToElement Element
layout [ParaElem]
hdrElems [Shape]
captionShapes [Shape]
contentShapes
  let animations :: [Element]
animations = case Maybe ContentWithCaptionShapeIds
shapeIds of
        Nothing -> []
        Just ContentWithCaptionShapeIds{..} ->
          [(Pixels, Shape)] -> [Element]
slideToIncrementalAnimations
            ([Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
contentWithCaptionCaptionIds [Shape]
captionShapes
             [(Pixels, Shape)] -> [(Pixels, Shape)] -> [(Pixels, Shape)]
forall a. Semigroup a => a -> a -> a
<> [Pixels] -> [Shape] -> [(Pixels, Shape)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pixels]
contentWithCaptionContentIds [Shape]
contentShapes)
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] (Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree]) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
animations)
slideToElement (Slide _ BlankSlide _ backgroundImage :: Maybe FilePath
backgroundImage) = do
  Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
BlankSlide
  Maybe Element
backgroundImageElement <- (FilePath -> P m Element)
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> P m Element
forall (m :: * -> *). PandocMonad m => FilePath -> P m Element
backgroundImageToElement Maybe FilePath
backgroundImage
  Element
spTree <- Element -> P m Element
forall (m :: * -> *). PandocMonad m => Element -> P m Element
blankToElement Element
layout
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sld"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] [Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" [] (Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe Element
backgroundImageElement [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element
spTree])]

backgroundImageToElement :: PandocMonad m => FilePath -> P m Element
backgroundImageToElement :: FilePath -> P m Element
backgroundImageToElement path :: FilePath
path = do
  MediaInfo{Int
mInfoLocalId :: Int
mInfoLocalId :: MediaInfo -> Int
mInfoLocalId, FilePath
mInfoFilePath :: FilePath
mInfoFilePath :: MediaInfo -> FilePath
mInfoFilePath} <- FilePath -> [ParaElem] -> P m MediaInfo
forall (m :: * -> *).
PandocMonad m =>
FilePath -> [ParaElem] -> P m MediaInfo
registerMedia FilePath
path []
  (imgBytes :: ByteString
imgBytes, _) <- Text
-> ReaderT
     WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (FilePath -> Text
T.pack FilePath
mInfoFilePath)
  WriterOptions
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOpts
  let imageDimensions :: Maybe (Pixels, Pixels)
imageDimensions = (Text -> Maybe (Pixels, Pixels))
-> (ImageSize -> Maybe (Pixels, Pixels))
-> Either Text ImageSize
-> Maybe (Pixels, Pixels)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Pixels, Pixels) -> Text -> Maybe (Pixels, Pixels)
forall a b. a -> b -> a
const Maybe (Pixels, Pixels)
forall a. Maybe a
Nothing)
                               ((Pixels, Pixels) -> Maybe (Pixels, Pixels)
forall a. a -> Maybe a
Just ((Pixels, Pixels) -> Maybe (Pixels, Pixels))
-> (ImageSize -> (Pixels, Pixels))
-> ImageSize
-> Maybe (Pixels, Pixels)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImageSize -> (Pixels, Pixels)
sizeInPixels)
                               (WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
imgBytes)
  (Pixels, Pixels)
pageSize <- (WriterEnv -> (Pixels, Pixels))
-> ReaderT WriterEnv (StateT WriterState m) (Pixels, Pixels)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> (Pixels, Pixels)
envPresentationSize
  let fillRectAttributes :: NameSpaces
fillRectAttributes = NameSpaces
-> ((Pixels, Pixels) -> NameSpaces)
-> Maybe (Pixels, Pixels)
-> NameSpaces
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Pixels, Pixels) -> (Pixels, Pixels) -> NameSpaces
offsetAttributes (Pixels, Pixels)
pageSize) Maybe (Pixels, Pixels)
imageDimensions
  let rId :: Text
rId = "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
mInfoLocalId)
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:bg" []
    (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:bgPr" []
    [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:blipFill" [("dpi", "0"), ("rotWithShape", "1")]
      [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:blip" [("r:embed", Text
rId)]
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lum" [] ()
      , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:srcRect" [] ()
      , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:stretch" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:fillRect" NameSpaces
fillRectAttributes ()
      ]
    , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:effectsLst" [] ()
    ]
  where
    offsetAttributes :: (Integer, Integer) -> (Integer, Integer) -> [(Text, Text)]
    offsetAttributes :: (Pixels, Pixels) -> (Pixels, Pixels) -> NameSpaces
offsetAttributes (pageWidth :: Pixels
pageWidth, pageHeight :: Pixels
pageHeight) (pictureWidth :: Pixels
pictureWidth, pictureHeight :: Pixels
pictureHeight) = let
      widthRatio :: Ratio Pixels
widthRatio = Pixels
pictureWidth Pixels -> Pixels -> Ratio Pixels
forall a. Integral a => a -> a -> Ratio a
% Pixels
pageWidth
      heightRatio :: Ratio Pixels
heightRatio = Pixels
pictureHeight Pixels -> Pixels -> Ratio Pixels
forall a. Integral a => a -> a -> Ratio a
% Pixels
pageHeight
      getOffset :: Ratio Integer -> Text
      getOffset :: Ratio Pixels -> Text
getOffset proportion :: Ratio Pixels
proportion = let
          percentageOffset :: Ratio Pixels
percentageOffset = (Ratio Pixels
proportion Ratio Pixels -> Ratio Pixels -> Ratio Pixels
forall a. Num a => a -> a -> a
- 1) Ratio Pixels -> Ratio Pixels -> Ratio Pixels
forall a. Num a => a -> a -> a
* (-100 Pixels -> Pixels -> Ratio Pixels
forall a. Integral a => a -> a -> Ratio a
% 2)
          integerOffset :: Pixels
integerOffset = Ratio Pixels -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Ratio Pixels
percentageOffset Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 1000 :: Integer
        in FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
integerOffset)
      in case Ratio Pixels -> Ratio Pixels -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Ratio Pixels
widthRatio Ratio Pixels
heightRatio of
        EQ -> []
        LT -> let
          offset :: Text
offset = Ratio Pixels -> Text
getOffset ((Pixels
pictureHeight Pixels -> Pixels -> Ratio Pixels
forall a. Integral a => a -> a -> Ratio a
% Pixels
pageHeight) Ratio Pixels -> Ratio Pixels -> Ratio Pixels
forall a. Fractional a => a -> a -> a
/ Ratio Pixels
widthRatio)
          in [ ("t", Text
offset)
             , ("b", Text
offset)
             ]
        GT -> let
          offset :: Text
offset = Ratio Pixels -> Text
getOffset ((Pixels
pictureWidth Pixels -> Pixels -> Ratio Pixels
forall a. Integral a => a -> a -> Ratio a
% Pixels
pageWidth) Ratio Pixels -> Ratio Pixels -> Ratio Pixels
forall a. Fractional a => a -> a -> a
/ Ratio Pixels
heightRatio)
          in [ ("l", Text
offset)
             , ("r", Text
offset)
             ]


slideToIncrementalAnimations ::
  [(ShapeId, Shape)] ->
  [Element]
slideToIncrementalAnimations :: [(Pixels, Shape)] -> [Element]
slideToIncrementalAnimations shapes :: [(Pixels, Shape)]
shapes = let
  incrementals :: [(ShapeId, [Bool])]
  incrementals :: [(Pixels, [Bool])]
incrementals = do
    (shapeId :: Pixels
shapeId, TextBox ps :: [Paragraph]
ps) <- [(Pixels, Shape)]
shapes
    (Pixels, [Bool]) -> [(Pixels, [Bool])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Pixels, [Bool]) -> [(Pixels, [Bool])])
-> ([Bool] -> (Pixels, [Bool])) -> [Bool] -> [(Pixels, [Bool])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pixels
shapeId,) ([Bool] -> [(Pixels, [Bool])]) -> [Bool] -> [(Pixels, [Bool])]
forall a b. (a -> b) -> a -> b
$ do
      Paragraph ParaProps{Bool
pPropIncremental :: ParaProps -> Bool
pPropIncremental :: Bool
pPropIncremental} _ <- [Paragraph]
ps
      Bool -> [Bool]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
pPropIncremental
  toIndices :: [Bool] -> Maybe (NonEmpty (Integer, Integer))
  toIndices :: [Bool] -> Maybe (NonEmpty (Pixels, Pixels))
toIndices bs :: [Bool]
bs = do
        let indexed :: [(Pixels, Bool)]
indexed = [Pixels] -> [Bool] -> [(Pixels, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Bool]
bs
        NonEmpty (Pixels, Bool)
ts <- [(Pixels, Bool)] -> Maybe (NonEmpty (Pixels, Bool))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (((Pixels, Bool) -> Bool) -> [(Pixels, Bool)] -> [(Pixels, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pixels, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Pixels, Bool)]
indexed)
        NonEmpty (Pixels, Pixels) -> Maybe (NonEmpty (Pixels, Pixels))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Pixels, Bool) -> (Pixels, Pixels))
-> NonEmpty (Pixels, Bool) -> NonEmpty (Pixels, Pixels)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(n :: Pixels
n, _) -> (Pixels
n, Pixels
n)) NonEmpty (Pixels, Bool)
ts)
  indices :: [(ShapeId, NonEmpty (Integer, Integer))]
  indices :: [(Pixels, NonEmpty (Pixels, Pixels))]
indices = do
    (shapeId :: Pixels
shapeId, bs :: [Bool]
bs) <- [(Pixels, [Bool])]
incrementals
    Maybe (Pixels, NonEmpty (Pixels, Pixels))
-> [(Pixels, NonEmpty (Pixels, Pixels))]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((,) Pixels
shapeId (NonEmpty (Pixels, Pixels) -> (Pixels, NonEmpty (Pixels, Pixels)))
-> Maybe (NonEmpty (Pixels, Pixels))
-> Maybe (Pixels, NonEmpty (Pixels, Pixels))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bool] -> Maybe (NonEmpty (Pixels, Pixels))
toIndices [Bool]
bs)
  in Maybe Element -> [Element]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (Pixels, NonEmpty (Pixels, Pixels)) -> Element
incrementalAnimation (NonEmpty (Pixels, NonEmpty (Pixels, Pixels)) -> Element)
-> Maybe (NonEmpty (Pixels, NonEmpty (Pixels, Pixels)))
-> Maybe Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Pixels, NonEmpty (Pixels, Pixels))]
-> Maybe (NonEmpty (Pixels, NonEmpty (Pixels, Pixels)))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(Pixels, NonEmpty (Pixels, Pixels))]
indices)

--------------------------------------------------------------------
-- Notes:

getNotesMaster :: PandocMonad m => P m Element
getNotesMaster :: P m Element
getNotesMaster = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/notesMasters/notesMaster1.xml"

getSlideNumberFieldId :: PandocMonad m => Element -> P m T.Text
getSlideNumberFieldId :: Element -> P m Text
getSlideNumberFieldId notesMaster :: Element
notesMaster
  | NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
notesMaster
  , Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "cSld") Element
notesMaster
  , Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
  , Just sp :: Element
sp <- NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType NameSpaces
ns Element
spTree (Text -> PHType
PHType "sldNum")
  , Just txBody :: Element
txBody <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "p" "txBody") Element
sp
  , Just p :: Element
p <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "p") Element
txBody
  , Just fld :: Element
fld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "a" "fld") Element
p
  , Just fldId :: Text
fldId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
fld =
      Text -> P m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
fldId
  | Bool
otherwise = PandocError -> P m Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Text) -> PandocError -> P m Text
forall a b. (a -> b) -> a -> b
$
                Text -> PandocError
PandocSomeError
                "No field id for slide numbers in notesMaster.xml"

speakerNotesSlideImage :: Element
speakerNotesSlideImage :: Element
speakerNotesSlideImage =
  Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" []
  [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvSpPr" []
    [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "2")
                       , ("name", "Slide Image Placeholder 1")
                       ] ()
    , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:spLocks" [ ("noGrp", "1")
                           , ("noRot", "1")
                           , ("noChangeAspect", "1")
                           ] ()
      ]
    , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:ph" [("type", "sldImg")] ()]
    ]
  , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
  ]

-- we want to wipe links from the speaker notes in the
-- paragraphs. Powerpoint doesn't allow you to input them, and it
-- would provide extra complications.
removeParaLinks :: Paragraph -> Paragraph
removeParaLinks :: Paragraph -> Paragraph
removeParaLinks paragraph :: Paragraph
paragraph = Paragraph
paragraph{paraElems :: [ParaElem]
paraElems = (ParaElem -> ParaElem) -> [ParaElem] -> [ParaElem]
forall a b. (a -> b) -> [a] -> [b]
map ParaElem -> ParaElem
f (Paragraph -> [ParaElem]
paraElems Paragraph
paragraph)}
  where f :: ParaElem -> ParaElem
f (Run rProps :: RunProps
rProps s :: Text
s) = RunProps -> Text -> ParaElem
Run RunProps
rProps{rLink :: Maybe LinkTarget
rLink=Maybe LinkTarget
forall a. Maybe a
Nothing} Text
s
        f pe :: ParaElem
pe             = ParaElem
pe

-- put an empty paragraph between paragraphs for more expected spacing.
spaceParas :: [Paragraph] -> [Paragraph]
spaceParas :: [Paragraph] -> [Paragraph]
spaceParas = Paragraph -> [Paragraph] -> [Paragraph]
forall a. a -> [a] -> [a]
intersperse (ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [])

speakerNotesBody :: PandocMonad m => [Paragraph] -> P m Element
speakerNotesBody :: [Paragraph] -> P m Element
speakerNotesBody paras :: [Paragraph]
paras = do
  [Element]
elements <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{envInSpeakerNotes :: Bool
envInSpeakerNotes = Bool
True}) (ReaderT WriterEnv (StateT WriterState m) [Element]
 -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall a b. (a -> b) -> a -> b
$
              (Paragraph -> P m Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement ([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall a b. (a -> b) -> a -> b
$ [Paragraph] -> [Paragraph]
spaceParas ([Paragraph] -> [Paragraph]) -> [Paragraph] -> [Paragraph]
forall a b. (a -> b) -> a -> b
$ (Paragraph -> Paragraph) -> [Paragraph] -> [Paragraph]
forall a b. (a -> b) -> [a] -> [b]
map Paragraph -> Paragraph
removeParaLinks [Paragraph]
paras
  let txBody :: Element
txBody = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
               [Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" []
    [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvSpPr" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "3")
                         , ("name", "Notes Placeholder 2")
                         ] ()
      , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" []
        [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:spLocks" [("noGrp", "1")] ()]
      , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" []
        [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:ph" [("type", "body"), ("idx", "1")] ()]
      ]
    , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
    , Element
txBody
    ]

speakerNotesSlideNumber :: Int -> T.Text -> Element
speakerNotesSlideNumber :: Int -> Text -> Element
speakerNotesSlideNumber pgNum :: Int
pgNum fieldId :: Text
fieldId =
  Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sp" []
  [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvSpPr" []
    [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "4")
                       , ("name", "Slide Number Placeholder 3")
                       ] ()
    , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:spLocks" [("noGrp", "1")] ()]
    , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:ph" [ ("type", "sldNum")
                      , ("sz", "quarter")
                      , ("idx", "10")
                      ] ()
      ]
    ]
  , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
  , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txBody" []
    [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] ()
    , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()
    , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:p" []
      [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:fld" [ ("id", Text
fieldId)
                       , ("type", "slidenum")
                       ]
        [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:rPr" [("lang", "en-US")] ()
        , Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:t" [] (Int -> Text
forall a. Show a => a -> Text
tshow Int
pgNum)
        ]
      , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:endParaRPr" [("lang", "en-US")] ()
      ]
    ]
  ]

slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesElement :: Slide -> P m (Maybe Element)
slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes []) _) = Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Element
forall a. Maybe a
Nothing
slideToSpeakerNotesElement slide :: Slide
slide@(Slide _ _ (SpeakerNotes paras :: [Paragraph]
paras) _) = do
  Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getNotesMaster
  Text
fieldId  <- Element -> P m Text
forall (m :: * -> *). PandocMonad m => Element -> P m Text
getSlideNumberFieldId Element
master
  Int
num <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  let imgShape :: Element
imgShape = Element
speakerNotesSlideImage
      sldNumShape :: Element
sldNumShape = Int -> Text -> Element
speakerNotesSlideNumber Int
num Text
fieldId
  Element
bodyShape <- [Paragraph] -> P m Element
forall (m :: * -> *). PandocMonad m => [Paragraph] -> P m Element
speakerNotesBody [Paragraph]
paras
  Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:notes"
    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main")
    , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships")
    , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
    ] [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cSld" []
        [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spTree" []
          [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvGrpSpPr" []
            [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id", "1"), ("name", "")] ()
            , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cNvGrpSpPr" [] ()
            , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()
            ]
          , Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:grpSpPr" []
            [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:xfrm" []
              [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:off" [("x", "0"), ("y", "0")] ()
              , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", "0"), ("cy", "0")] ()
              , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:chOff" [("x", "0"), ("y", "0")] ()
              , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "a:chExt" [("cx", "0"), ("cy", "0")] ()
              ]
            ]
          , Element
imgShape
          , Element
bodyShape
          , Element
sldNumShape
          ]
        ]
      ]

-----------------------------------------------------------------------

getSlideIdNum :: PandocMonad m => SlideId -> P m Int
getSlideIdNum :: SlideId -> P m Int
getSlideIdNum sldId :: SlideId
sldId = do
  Map SlideId Int
slideIdMap <- (WriterEnv -> Map SlideId Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map SlideId Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map SlideId Int
envSlideIdMap
  case  SlideId -> Map SlideId Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SlideId
sldId Map SlideId Int
slideIdMap of
    Just n :: Int
n -> Int -> P m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
    Nothing -> PandocError -> P m Int
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Int) -> PandocError -> P m Int
forall a b. (a -> b) -> a -> b
$
               Text -> PandocError
PandocShouldNeverHappenError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$
               "Slide Id " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SlideId -> Text
forall a. Show a => a -> Text
tshow SlideId
sldId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " not found."

slideNum :: PandocMonad m => Slide -> P m Int
slideNum :: Slide -> P m Int
slideNum slide :: Slide
slide = SlideId -> P m Int
forall (m :: * -> *). PandocMonad m => SlideId -> P m Int
getSlideIdNum (SlideId -> P m Int) -> SlideId -> P m Int
forall a b. (a -> b) -> a -> b
$ Slide -> SlideId
slideId Slide
slide

idNumToFilePath :: Int -> FilePath
idNumToFilePath :: Int -> FilePath
idNumToFilePath idNum :: Int
idNum = "slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml"

slideToFilePath :: PandocMonad m => Slide -> P m FilePath
slideToFilePath :: Slide -> P m FilePath
slideToFilePath slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  FilePath -> P m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> P m FilePath) -> FilePath -> P m FilePath
forall a b. (a -> b) -> a -> b
$ "slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml"

slideToRelId ::
  PandocMonad m =>
  MinimumRId ->
  Slide ->
  P m T.Text
slideToRelId :: Int -> Slide -> P m Text
slideToRelId minSlideRId :: Int
minSlideRId slide :: Slide
slide = do
  Int
n <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Text -> P m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> P m Text) -> Text -> P m Text
forall a b. (a -> b) -> a -> b
$ "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minSlideRId Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)


data Relationship = Relationship { Relationship -> Int
relId :: Int
                                 , Relationship -> Text
relType :: MimeType
                                 , Relationship -> FilePath
relTarget :: FilePath
                                 } deriving (Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> FilePath
(Int -> Relationship -> ShowS)
-> (Relationship -> FilePath)
-> ([Relationship] -> ShowS)
-> Show Relationship
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> FilePath
$cshow :: Relationship -> FilePath
showsPrec :: Int -> Relationship -> ShowS
$cshowsPrec :: Int -> Relationship -> ShowS
Show, Relationship -> Relationship -> Bool
(Relationship -> Relationship -> Bool)
-> (Relationship -> Relationship -> Bool) -> Eq Relationship
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relationship -> Relationship -> Bool
$c/= :: Relationship -> Relationship -> Bool
== :: Relationship -> Relationship -> Bool
$c== :: Relationship -> Relationship -> Bool
Eq)

elementToRel :: Element -> Maybe Relationship
elementToRel :: Element -> Maybe Relationship
elementToRel element :: Element
element
  | Element -> QName
elName Element
element QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text -> Maybe Text -> QName
QName "Relationship" (Text -> Maybe Text
forall a. a -> Maybe a
Just "http://schemas.openxmlformats.org/package/2006/relationships") Maybe Text
forall a. Maybe a
Nothing =
      do Text
rId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
         Text
numStr <- Text -> Text -> Maybe Text
T.stripPrefix "rId" Text
rId
         Int
num <- Pixels -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pixels -> Int) -> Maybe Pixels -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Pixels
readTextAsInteger Text
numStr
         Text
type' <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
         Text
target <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
         Relationship -> Maybe Relationship
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> Maybe Relationship)
-> Relationship -> Maybe Relationship
forall a b. (a -> b) -> a -> b
$ Int -> Text -> FilePath -> Relationship
Relationship Int
num Text
type' (Text -> FilePath
T.unpack Text
target)
  | Bool
otherwise = Maybe Relationship
forall a. Maybe a
Nothing

slideToPresRel :: PandocMonad m => Int -> Slide -> P m Relationship
slideToPresRel :: Int -> Slide -> P m Relationship
slideToPresRel minimumSlideRId :: Int
minimumSlideRId slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  let rId :: Int
rId = Int
idNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minimumSlideRId Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
      fp :: FilePath
fp = "slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum
  Relationship -> P m Relationship
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> P m Relationship)
-> Relationship -> P m Relationship
forall a b. (a -> b) -> a -> b
$ Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = Int
rId
                        , relType :: Text
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
                        , relTarget :: FilePath
relTarget = FilePath
fp
                        }

getPresentationRels :: PandocMonad m => P m [Relationship]
getPresentationRels :: P m [Relationship]
getPresentationRels = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Element
relsElem <- Archive
-> Archive
-> FilePath
-> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/_rels/presentation.xml.rels"
  let globalNS :: Text
globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
  let relElems :: [Element]
relElems = QName -> Element -> [Element]
findChildren (Text -> Maybe Text -> Maybe Text -> QName
QName "Relationship" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
globalNS) Maybe Text
forall a. Maybe a
Nothing) Element
relsElem
  [Relationship] -> P m [Relationship]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Relationship] -> P m [Relationship])
-> [Relationship] -> P m [Relationship]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe Relationship) -> [Element] -> [Relationship]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe Relationship
elementToRel [Element]
relElems

-- | Info required to update a presentation rId from the reference doc for the
-- output.
type PresentationRIdUpdateData = (ReferenceMinRIdAfterSlides, NewRIdBounds)

-- | The minimum and maximum rIds for presentation relationships created from
-- the presentation content (as opposed to from the reference doc).
--
-- Relationships taken from the reference doc should have their rId number
-- adjusted to make sure it sits outside this range.
type NewRIdBounds = (MinimumRId, MaximumRId)

-- | The minimum presentation rId from the reference doc which comes after the
-- first slide rId (in the reference doc).
type ReferenceMinRIdAfterSlides = Int
type MinimumRId = Int
type MaximumRId = Int

-- | Given a presentation rId from the reference doc, return the value it should
-- have in the output.
updatePresentationRId :: PresentationRIdUpdateData -> Int -> Int
updatePresentationRId :: PresentationRIdUpdateData -> Int -> Int
updatePresentationRId (minOverlappingRId :: Int
minOverlappingRId, (minNewId :: Int
minNewId, maxNewId :: Int
maxNewId)) n :: Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minNewId = Int
n
  | Bool
otherwise = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minOverlappingRId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxNewId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

presentationToRels ::
  PandocMonad m =>
  Presentation ->
  P m (PresentationRIdUpdateData, [Relationship])
presentationToRels :: Presentation -> P m (PresentationRIdUpdateData, [Relationship])
presentationToRels pres :: Presentation
pres@(Presentation _ slides :: [Slide]
slides) = do
  [Relationship]
rels <- P m [Relationship]
forall (m :: * -> *). PandocMonad m => P m [Relationship]
getPresentationRels

  -- We want to make room for the slides in the id space. We'll assume the slide
  -- masters come first (this seems to be what PowerPoint does by default, and
  -- is true of the reference doc), and we'll put the slides next. So we find
  -- the starting rId for the slides by finding the maximum rId for the masters
  -- and adding 1.
  --
  -- Then:
  -- 1. We look to see what the minimum rId which is greater than or equal to
  --    the minimum slide rId is, in the rels we're keeping from the reference
  --    doc (i.e. the minimum rId which might overlap with the slides).
  -- 2. We increase this minimum overlapping rId to 1 higher than the last slide
  --    rId (or the notesMaster rel, if we're including one), and increase all
  --    rIds higher than this minimum by the same amount.

  let masterRels :: [Relationship]
masterRels = (Relationship -> Bool) -> [Relationship] -> [Relationship]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
T.isSuffixOf "slideMaster" (Text -> Bool) -> (Relationship -> Text) -> Relationship -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relationship -> Text
relType) [Relationship]
rels
      slideStartId :: Int
slideStartId = Int
-> (NonEmpty Relationship -> Int)
-> Maybe (NonEmpty Relationship)
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 1 ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> Int)
-> (NonEmpty Relationship -> Int) -> NonEmpty Relationship -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (NonEmpty Int -> Int)
-> (NonEmpty Relationship -> NonEmpty Int)
-> NonEmpty Relationship
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Relationship -> Int) -> NonEmpty Relationship -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Relationship -> Int
relId) ([Relationship] -> Maybe (NonEmpty Relationship)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Relationship]
masterRels)
      -- we remove the slide rels and the notesmaster (if it's
      -- there). We'll put these back in ourselves, if necessary.
      relsWeKeep :: [Relationship]
relsWeKeep = (Relationship -> Bool) -> [Relationship] -> [Relationship]
forall a. (a -> Bool) -> [a] -> [a]
filter
                   (\r :: Relationship
r -> Relationship -> Text
relType Relationship
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" Bool -> Bool -> Bool
&&
                          Relationship -> Text
relType Relationship
r Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
                   [Relationship]
rels
      minOverlappingRel :: Int
minOverlappingRel = Int -> (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 NonEmpty Int -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum
                                 ([Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int
slideStartId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=)
                                                   (Relationship -> Int
relId (Relationship -> Int) -> [Relationship] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Relationship]
relsWeKeep)))

  [Relationship]
mySlideRels <- (Slide -> ReaderT WriterEnv (StateT WriterState m) Relationship)
-> [Slide] -> P m [Relationship]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int
-> Slide -> ReaderT WriterEnv (StateT WriterState m) Relationship
forall (m :: * -> *).
PandocMonad m =>
Int -> Slide -> P m Relationship
slideToPresRel Int
slideStartId) [Slide]
slides

  let notesMasterRels :: [Relationship]
notesMasterRels =
        [Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = Int
slideStartId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Relationship] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Relationship]
mySlideRels
                         , relType :: Text
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster"
                         , relTarget :: FilePath
relTarget = "notesMasters/notesMaster1.xml"
                         } | Presentation -> Bool
presHasSpeakerNotes Presentation
pres]
      insertedRels :: [Relationship]
insertedRels = [Relationship]
mySlideRels [Relationship] -> [Relationship] -> [Relationship]
forall a. Semigroup a => a -> a -> a
<> [Relationship]
notesMasterRels
      newRIdBounds :: (Int, Int)
newRIdBounds = (Int
slideStartId, Int
slideStartId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Relationship] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Relationship]
insertedRels Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
      updateRId :: Int -> Int
updateRId = PresentationRIdUpdateData -> Int -> Int
updatePresentationRId (Int
minOverlappingRel, (Int, Int)
newRIdBounds)

      relsWeKeep' :: [Relationship]
relsWeKeep' = (Relationship -> Relationship) -> [Relationship] -> [Relationship]
forall a b. (a -> b) -> [a] -> [b]
map (\r :: Relationship
r -> Relationship
r{relId :: Int
relId = Int -> Int
updateRId (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Relationship -> Int
relId Relationship
r}) [Relationship]
relsWeKeep

  (PresentationRIdUpdateData, [Relationship])
-> P m (PresentationRIdUpdateData, [Relationship])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
minOverlappingRel, (Int, Int)
newRIdBounds), [Relationship]
insertedRels [Relationship] -> [Relationship] -> [Relationship]
forall a. Semigroup a => a -> a -> a
<> [Relationship]
relsWeKeep')

-- We make this ourselves, in case there's a thumbnail in the one from
-- the template.
topLevelRels :: [Relationship]
topLevelRels :: [Relationship]
topLevelRels =
  [ Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = 1
                 , relType :: Text
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"
                 , relTarget :: FilePath
relTarget = "ppt/presentation.xml"
                 }
  , Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = 2
                 , relType :: Text
relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties"
                 , relTarget :: FilePath
relTarget = "docProps/core.xml"
                 }
  , Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = 3
                 , relType :: Text
relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties"
                 , relTarget :: FilePath
relTarget = "docProps/app.xml"
                 }
  , Relationship :: Int -> Text -> FilePath -> Relationship
Relationship { relId :: Int
relId = 4
                 , relType :: Text
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties"
                 , relTarget :: FilePath
relTarget = "docProps/custom.xml"
                 }
  ]

topLevelRelsEntry :: PandocMonad m => P m Entry
topLevelRelsEntry :: P m Entry
topLevelRelsEntry = FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "_rels/.rels" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ [Relationship] -> Element
relsToElement [Relationship]
topLevelRels

relToElement :: Relationship -> Element
relToElement :: Relationship -> Element
relToElement rel :: Relationship
rel = Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Relationship -> Int
relId Relationship
rel))
                                         , ("Type", Relationship -> Text
relType Relationship
rel)
                                         , ("Target", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Relationship -> FilePath
relTarget Relationship
rel) ] ()

relsToElement :: [Relationship] -> Element
relsToElement :: [Relationship] -> Element
relsToElement rels :: [Relationship]
rels = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationships"
                     [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
                     ((Relationship -> Element) -> [Relationship] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Relationship -> Element
relToElement [Relationship]
rels)

presentationToRelsEntry ::
  PandocMonad m =>
  Presentation ->
  P m (PresentationRIdUpdateData, Entry)
presentationToRelsEntry :: Presentation -> P m (PresentationRIdUpdateData, Entry)
presentationToRelsEntry pres :: Presentation
pres = do
  (presentationRIdUpdateData :: PresentationRIdUpdateData
presentationRIdUpdateData, rels :: [Relationship]
rels) <- Presentation -> P m (PresentationRIdUpdateData, [Relationship])
forall (m :: * -> *).
PandocMonad m =>
Presentation -> P m (PresentationRIdUpdateData, [Relationship])
presentationToRels Presentation
pres
  Entry
element <- FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/_rels/presentation.xml.rels" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ [Relationship] -> Element
relsToElement [Relationship]
rels
  (PresentationRIdUpdateData, Entry)
-> P m (PresentationRIdUpdateData, Entry)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PresentationRIdUpdateData
presentationRIdUpdateData, Entry
element)

elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
elemToEntry :: FilePath -> Element -> P m Entry
elemToEntry fp :: FilePath
fp element :: Element
element = do
  Pixels
epochtime <- POSIXTime -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Pixels)
-> (UTCTime -> POSIXTime) -> UTCTime -> Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> Pixels)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
-> ReaderT WriterEnv (StateT WriterState m) Pixels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
  Entry -> P m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> P m Entry) -> Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Pixels -> ByteString -> Entry
toEntry FilePath
fp Pixels
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
element

slideToEntry :: PandocMonad m => Slide -> P m Entry
slideToEntry :: Slide -> P m Entry
slideToEntry slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  (WriterEnv -> WriterEnv) -> P m Entry -> P m Entry
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{envCurSlideId :: Int
envCurSlideId = Int
idNum}) (P m Entry -> P m Entry) -> P m Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ do
    Element
element <- Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Slide -> P m Element
slideToElement Slide
slide
    FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry ("ppt/slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum) Element
element

slideToSpeakerNotesEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry :: Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  (WriterEnv -> WriterEnv) -> P m (Maybe Entry) -> P m (Maybe Entry)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{envCurSlideId :: Int
envCurSlideId = Int
idNum}) (P m (Maybe Entry) -> P m (Maybe Entry))
-> P m (Maybe Entry) -> P m (Maybe Entry)
forall a b. (a -> b) -> a -> b
$ do
    Maybe Element
mbElement <- Slide -> P m (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesElement Slide
slide
    Maybe Int
mbNotesIdNum <- do Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
                       Maybe Int -> ReaderT WriterEnv (StateT WriterState m) (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> ReaderT WriterEnv (StateT WriterState m) (Maybe Int))
-> Maybe Int
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp
    case Maybe Element
mbElement of
      Just element :: Element
element | Just notesIdNum :: Int
notesIdNum <- Maybe Int
mbNotesIdNum ->
                       Entry -> Maybe Entry
forall a. a -> Maybe a
Just (Entry -> Maybe Entry)
-> ReaderT WriterEnv (StateT WriterState m) Entry
-> P m (Maybe Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       FilePath
-> Element -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry
                       ("ppt/notesSlides/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
notesIdNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                        ".xml")
                       Element
element
      _ -> Maybe Entry -> P m (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Entry
forall a. Maybe a
Nothing

slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement :: Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes []) _) = Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Element
forall a. Maybe a
Nothing
slideToSpeakerNotesRelElement slide :: Slide
slide@Slide{} = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationships"
    [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
    [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId2")
                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
                            , ("Target", "../slides/slide" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
idNum Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".xml")
                            ] ()
    , Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId1")
                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
                            , ("Target", "../notesMasters/notesMaster1.xml")
                            ] ()
    ]


slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry :: Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Maybe Element
mbElement <- Slide -> P m (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement Slide
slide
  Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
  let mbNotesIdNum :: Maybe Int
mbNotesIdNum = Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp
  case Maybe Element
mbElement of
    Just element :: Element
element | Just notesIdNum :: Int
notesIdNum <- Maybe Int
mbNotesIdNum ->
      Entry -> Maybe Entry
forall a. a -> Maybe a
Just (Entry -> Maybe Entry)
-> ReaderT WriterEnv (StateT WriterState m) Entry
-> P m (Maybe Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      FilePath
-> Element -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry
      ("ppt/notesSlides/_rels/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
notesIdNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml.rels")
      Element
element
    _ -> Maybe Entry -> P m (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Entry
forall a. Maybe a
Nothing

slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry
slideToSlideRelEntry :: Slide -> P m Entry
slideToSlideRelEntry slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Element
element <- Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Slide -> P m Element
slideToSlideRelElement Slide
slide
  FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry ("ppt/slides/_rels/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".rels") Element
element

linkRelElement :: PandocMonad m => (Int, LinkTarget) -> P m Element
linkRelElement :: (Int, LinkTarget) -> P m Element
linkRelElement (rIdNum :: Int
rIdNum, InternalTarget targetId :: SlideId
targetId) = do
  Int
targetIdNum <- SlideId -> P m Int
forall (m :: * -> *). PandocMonad m => SlideId -> P m Int
getSlideIdNum SlideId
targetId
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
rIdNum)
                          , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
                          , ("Target", "slide" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
targetIdNum Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".xml")
                          ] ()
linkRelElement (rIdNum :: Int
rIdNum, ExternalTarget (url :: Text
url, _)) =
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
rIdNum)
                          , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
                          , ("Target", Text
url)
                          , ("TargetMode", "External")
                          ] ()

linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element]
linkRelElements :: Map Int LinkTarget -> P m [Element]
linkRelElements mp :: Map Int LinkTarget
mp = ((Int, LinkTarget)
 -> ReaderT WriterEnv (StateT WriterState m) Element)
-> [(Int, LinkTarget)] -> P m [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, LinkTarget)
-> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
(Int, LinkTarget) -> P m Element
linkRelElement (Map Int LinkTarget -> [(Int, LinkTarget)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int LinkTarget
mp)

mediaRelElement :: MediaInfo -> Element
mediaRelElement :: MediaInfo -> Element
mediaRelElement mInfo :: MediaInfo
mInfo =
  let ext :: Text
ext = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (MediaInfo -> Maybe Text
mInfoExt MediaInfo
mInfo)
  in
    Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Int -> Text
forall a. Show a => a -> Text
tshow (MediaInfo -> Int
mInfoLocalId MediaInfo
mInfo))
                          , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
                          , ("Target", "../media/image" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Int -> Text
forall a. Show a => a -> Text
tshow (MediaInfo -> Int
mInfoGlobalId MediaInfo
mInfo) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ext)
                          ] ()

speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
speakerNotesSlideRelElement :: Slide -> P m (Maybe Element)
speakerNotesSlideRelElement slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
  Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ case Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp of
    Nothing -> Maybe Element
forall a. Maybe a
Nothing
    Just n :: Int
n ->
      let target :: Text
target = "../notesSlides/notesSlide" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".xml"
      in Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
         Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId2")
                               , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide")
                               , ("Target", Text
target)
                               ] ()

slideToSlideRelElement :: PandocMonad m => Slide -> P m Element
slideToSlideRelElement :: Slide -> P m Element
slideToSlideRelElement slide :: Slide
slide = do
  Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  Text
target <- ((SlideLayouts -> Text)
 -> ReaderT WriterEnv (StateT WriterState m) SlideLayouts
 -> ReaderT WriterEnv (StateT WriterState m) Text)
-> ReaderT WriterEnv (StateT WriterState m) SlideLayouts
-> (SlideLayouts -> Text)
-> ReaderT WriterEnv (StateT WriterState m) Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SlideLayouts -> Text)
-> ReaderT WriterEnv (StateT WriterState m) SlideLayouts
-> ReaderT WriterEnv (StateT WriterState m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReaderT WriterEnv (StateT WriterState m) SlideLayouts
forall (m :: * -> *). PandocMonad m => P m SlideLayouts
getSlideLayouts ((SlideLayouts -> Text)
 -> ReaderT WriterEnv (StateT WriterState m) Text)
-> (SlideLayouts -> Text)
-> ReaderT WriterEnv (StateT WriterState m) Text
forall a b. (a -> b) -> a -> b
$
    FilePath -> Text
T.pack (FilePath -> Text)
-> (SlideLayouts -> FilePath) -> SlideLayouts -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("../slideLayouts/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (SlideLayouts -> FilePath) -> SlideLayouts -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeFileName ShowS -> (SlideLayouts -> FilePath) -> SlideLayouts -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    SlideLayout -> FilePath
slPath (SlideLayout -> FilePath)
-> (SlideLayouts -> SlideLayout) -> SlideLayouts -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case Slide
slide of
        (Slide _ MetadataSlide{} _ _)           -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
metadata
        (Slide _ TitleSlide{} _ _)              -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
title
        (Slide _ ContentSlide{} _ _)            -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
content
        (Slide _ TwoColumnSlide{} _ _)          -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
twoColumn
        (Slide _ ComparisonSlide{} _ _)         -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
comparison
        (Slide _ ContentWithCaptionSlide{} _ _) -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
contentWithCaption
        (Slide _ BlankSlide _ _)                -> SlideLayouts -> SlideLayout
forall a. SlideLayoutsOf a -> a
blank

  [Element]
speakerNotesRels <- Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList (Maybe Element -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
speakerNotesSlideRelElement Slide
slide

  Map Int (Map Int LinkTarget)
linkIds <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
     WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
  Map Int [MediaInfo]
mediaIds <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds

  [Element]
linkRels <- case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int (Map Int LinkTarget)
linkIds of
                Just mp :: Map Int LinkTarget
mp -> Map Int LinkTarget
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
Map Int LinkTarget -> P m [Element]
linkRelElements Map Int LinkTarget
mp
                Nothing -> [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  let mediaRels :: [Element]
mediaRels = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int [MediaInfo]
mediaIds of
                   Just mInfos :: [MediaInfo]
mInfos -> (MediaInfo -> Element) -> [MediaInfo] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map MediaInfo -> Element
mediaRelElement [MediaInfo]
mInfos
                   Nothing -> []

  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationships"
    [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
    ([Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId1")
                           , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
                           , ("Target", Text
target)] ()
    ] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
speakerNotesRels [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
linkRels [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
mediaRels)

slideToSldIdElement ::
  PandocMonad m =>
  MinimumRId ->
  Slide ->
  P m Element
slideToSldIdElement :: Int -> Slide -> P m Element
slideToSldIdElement minimumSlideRId :: Int
minimumSlideRId slide :: Slide
slide = do
  Int
n <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
  let id' :: Text
id' = Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 255
  Text
rId <- Int -> Slide -> P m Text
forall (m :: * -> *). PandocMonad m => Int -> Slide -> P m Text
slideToRelId Int
minimumSlideRId Slide
slide
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sldId" [("id", Text
id'), ("r:id", Text
rId)] ()

presentationToSldIdLst ::
  PandocMonad m =>
  MinimumRId ->
  Presentation ->
  P m Element
presentationToSldIdLst :: Int -> Presentation -> P m Element
presentationToSldIdLst minimumSlideRId :: Int
minimumSlideRId (Presentation _ slides :: [Slide]
slides) = do
  [Element]
ids <- (Slide -> P m Element)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Int -> Slide -> P m Element
slideToSldIdElement Int
minimumSlideRId) [Slide]
slides
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sldIdLst" [] [Element]
ids

presentationToPresentationElement ::
  PandocMonad m =>
  PresentationRIdUpdateData ->
  Presentation ->
  P m Element
presentationToPresentationElement :: PresentationRIdUpdateData -> Presentation -> P m Element
presentationToPresentationElement presentationUpdateRIdData :: PresentationRIdUpdateData
presentationUpdateRIdData pres :: Presentation
pres = do
  let (_, (minSlideRId :: Int
minSlideRId, maxSlideRId :: Int
maxSlideRId)) = PresentationRIdUpdateData
presentationUpdateRIdData
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Element
element <- Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/presentation.xml"
  Element
sldIdLst <- Int -> Presentation -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Int -> Presentation -> P m Element
presentationToSldIdLst Int
minSlideRId Presentation
pres

  let modifySldIdLst :: Content -> Content
      modifySldIdLst :: Content -> Content
modifySldIdLst (Elem e :: Element
e) = case Element -> QName
elName Element
e of
        (QName "sldIdLst" _ _) -> Element -> Content
Elem Element
sldIdLst
        _                      -> Element -> Content
Elem Element
e
      modifySldIdLst ct :: Content
ct = Content
ct

      notesMasterRId :: Int
notesMasterRId = Int
maxSlideRId

      notesMasterElem :: Element
notesMasterElem =  Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:notesMasterIdLst" []
                         [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode
                           "p:notesMasterId"
                           [("r:id", "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
notesMasterRId)]
                           ()
                         ]

      -- if there's a notesMasterIdLst in the presentation.xml file,
      -- we want to remove it. We then want to put our own, if
      -- necessary, after the slideMasterIdLst element. We also remove
      -- handouts master, since we don't want it.

      removeUnwantedMaster' :: Content -> [Content]
      removeUnwantedMaster' :: Content -> [Content]
removeUnwantedMaster' (Elem e :: Element
e) = case Element -> QName
elName Element
e of
        (QName "notesMasterIdLst" _ _) -> []
        (QName "handoutMasterIdLst" _ _) -> []
        _                              -> [Element -> Content
Elem Element
e]
      removeUnwantedMaster' ct :: Content
ct = [Content
ct]

      removeUnwantedMaster :: [Content] -> [Content]
      removeUnwantedMaster :: [Content] -> [Content]
removeUnwantedMaster = (Content -> [Content]) -> [Content] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [Content]
removeUnwantedMaster'

      insertNotesMaster' :: Content -> [Content]
      insertNotesMaster' :: Content -> [Content]
insertNotesMaster' (Elem e :: Element
e) = case Element -> QName
elName Element
e of
        (QName "sldMasterIdLst" _ _) -> [Element -> Content
Elem Element
e, Element -> Content
Elem Element
notesMasterElem]
        _                            -> [Element -> Content
Elem Element
e]
      insertNotesMaster' ct :: Content
ct = [Content
ct]

      insertNotesMaster :: [Content] -> [Content]
      insertNotesMaster :: [Content] -> [Content]
insertNotesMaster = if Presentation -> Bool
presHasSpeakerNotes Presentation
pres
                          then (Content -> [Content]) -> [Content] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [Content]
insertNotesMaster'
                          else [Content] -> [Content]
forall a. a -> a
id

      updateRIds :: Content -> Content
      updateRIds :: Content -> Content
updateRIds (Elem el :: Element
el) =
        Element -> Content
Elem (Element
el { elAttribs :: [Attr]
elAttribs = (Attr -> Attr) -> [Attr] -> [Attr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attr -> Attr
updateRIdAttribute (Element -> [Attr]
elAttribs Element
el)
                 , elContent :: [Content]
elContent = (Content -> Content) -> [Content] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Content -> Content
updateRIds (Element -> [Content]
elContent Element
el)
                 })
      updateRIds content :: Content
content = Content
content

      updateRIdAttribute :: XML.Attr -> XML.Attr
      updateRIdAttribute :: Attr -> Attr
updateRIdAttribute attr :: Attr
attr = Attr -> Maybe Attr -> Attr
forall a. a -> Maybe a -> a
fromMaybe Attr
attr (Maybe Attr -> Attr) -> Maybe Attr -> Attr
forall a b. (a -> b) -> a -> b
$ do
        Int
oldValue <- case Attr -> QName
attrKey Attr
attr of
          QName "id" _ (Just "r") ->
            Text -> Text -> Maybe Text
T.stripPrefix "rId" (Attr -> Text
attrVal Attr
attr)
            Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pixels -> Int) -> Maybe Pixels -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pixels -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Pixels -> Maybe Int)
-> (Text -> Maybe Pixels) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Pixels
readTextAsInteger
          _ -> Maybe Int
forall a. Maybe a
Nothing
        let newValue :: Int
newValue = PresentationRIdUpdateData -> Int -> Int
updatePresentationRId PresentationRIdUpdateData
presentationUpdateRIdData Int
oldValue
        Attr -> Maybe Attr
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attr
attr {attrVal :: Text
attrVal = "rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
newValue)}

      newContent :: [Content]
newContent = [Content] -> [Content]
insertNotesMaster ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$
                   [Content] -> [Content]
removeUnwantedMaster ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$
                   (Content -> Content
modifySldIdLst (Content -> Content) -> (Content -> Content) -> Content -> Content
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Content
updateRIds) (Content -> Content) -> [Content] -> [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   Element -> [Content]
elContent Element
element

  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Element
element{elContent :: [Content]
elContent = [Content]
newContent}

presentationToPresEntry :: PandocMonad m => PresentationRIdUpdateData -> Presentation -> P m Entry
presentationToPresEntry :: PresentationRIdUpdateData -> Presentation -> P m Entry
presentationToPresEntry presentationRIdUpdateData :: PresentationRIdUpdateData
presentationRIdUpdateData pres :: Presentation
pres =
  PresentationRIdUpdateData -> Presentation -> P m Element
forall (m :: * -> *).
PandocMonad m =>
PresentationRIdUpdateData -> Presentation -> P m Element
presentationToPresentationElement PresentationRIdUpdateData
presentationRIdUpdateData Presentation
pres P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/presentation.xml"

-- adapted from the Docx writer
docPropsElement :: PandocMonad m => DocProps -> P m Element
docPropsElement :: DocProps -> P m Element
docPropsElement docProps :: DocProps
docProps = do
  UTCTime
utctime <- (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
  let keywords :: Text
keywords = case DocProps -> Maybe [Text]
dcKeywords DocProps
docProps of
        Just xs :: [Text]
xs -> Text -> [Text] -> Text
T.intercalate ", " [Text]
xs
        Nothing -> ""
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "cp:coreProperties"
    [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
    ,("xmlns:dc","http://purl.org/dc/elements/1.1/")
    ,("xmlns:dcterms","http://purl.org/dc/terms/")
    ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/")
    ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")]
    ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
      Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dc:title" [] (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe Text
dcTitle DocProps
docProps)
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:
      Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dc:creator" [] (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe Text
dcCreator DocProps
docProps)
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:
      Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "cp:keywords" [] Text
keywords
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: ( [Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dc:subject" [] (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe Text
dcSubject DocProps
docProps | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (DocProps -> Maybe Text
dcSubject DocProps
docProps)])
    [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> ( [Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dc:description" [] (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe Text
dcDescription DocProps
docProps | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (DocProps -> Maybe Text
dcDescription DocProps
docProps)])
    [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> ( [Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "cp:category" [] (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe Text
cpCategory DocProps
docProps | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (DocProps -> Maybe Text
cpCategory DocProps
docProps)])
    [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> (\x :: Text
x -> [ Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] Text
x
              , Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] Text
x
              ]) (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%FT%XZ" UTCTime
utctime)

docPropsToEntry :: PandocMonad m => DocProps -> P m Entry
docPropsToEntry :: DocProps -> P m Entry
docPropsToEntry docProps :: DocProps
docProps = DocProps -> P m Element
forall (m :: * -> *). PandocMonad m => DocProps -> P m Element
docPropsElement DocProps
docProps P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                           FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "docProps/core.xml"

-- adapted from the Docx writer
docCustomPropsElement :: PandocMonad m => DocProps -> P m Element
docCustomPropsElement :: DocProps -> P m Element
docCustomPropsElement docProps :: DocProps
docProps = do
  let mkCustomProp :: (Text, t) -> a -> Element
mkCustomProp (k :: Text
k, v :: t
v) pid :: a
pid = Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "property"
         [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
         ,("pid", a -> Text
forall a. Show a => a -> Text
tshow a
pid)
         ,("name", Text
k)] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> t -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "vt:lpwstr" [] t
v
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Properties"
          [("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties")
          ,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")
          ] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Int -> Element)
-> NameSpaces -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text, Text) -> Int -> Element
forall a t. (Show a, Node t) => (Text, t) -> a -> Element
mkCustomProp (NameSpaces -> Maybe NameSpaces -> NameSpaces
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe NameSpaces -> NameSpaces) -> Maybe NameSpaces -> NameSpaces
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe NameSpaces
customProperties DocProps
docProps) [(2 :: Int)..]

docCustomPropsToEntry :: PandocMonad m => DocProps -> P m Entry
docCustomPropsToEntry :: DocProps -> P m Entry
docCustomPropsToEntry docProps :: DocProps
docProps = DocProps -> P m Element
forall (m :: * -> *). PandocMonad m => DocProps -> P m Element
docCustomPropsElement DocProps
docProps P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                           FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "docProps/custom.xml"

-- We read from the template, but we remove the lastView, so it always
-- opens on slide view. Templates will sometimes be open in master
-- view for editing.
viewPropsElement :: PandocMonad m => P m Element
viewPropsElement :: P m Element
viewPropsElement = do
  Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
  Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
  Element
viewPrElement <- Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/viewProps.xml"
  -- remove  "lastView" if it exists:
  let notLastView :: XML.Attr -> Bool
      notLastView :: Attr -> Bool
notLastView attr :: Attr
attr =
          QName -> Text
qName (Attr -> QName
attrKey Attr
attr) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "lastView"
  Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
    Element
viewPrElement {elAttribs :: [Attr]
elAttribs = (Attr -> Bool) -> [Attr] -> [Attr]
forall a. (a -> Bool) -> [a] -> [a]
filter Attr -> Bool
notLastView (Element -> [Attr]
elAttribs Element
viewPrElement)}

makeViewPropsEntry :: PandocMonad m => P m Entry
makeViewPropsEntry :: P m Entry
makeViewPropsEntry = P m Element
forall (m :: * -> *). PandocMonad m => P m Element
viewPropsElement P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/viewProps.xml"

defaultContentTypeToElem :: DefaultContentType -> Element
defaultContentTypeToElem :: DefaultContentType -> Element
defaultContentTypeToElem dct :: DefaultContentType
dct =
  Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Default"
  [("Extension", DefaultContentType -> Text
defContentTypesExt DefaultContentType
dct),
    ("ContentType", DefaultContentType -> Text
defContentTypesType DefaultContentType
dct)]
  ()

overrideContentTypeToElem :: OverrideContentType -> Element
overrideContentTypeToElem :: OverrideContentType -> Element
overrideContentTypeToElem oct :: OverrideContentType
oct =
  Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Override"
  [("PartName", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ OverrideContentType -> FilePath
overrideContentTypesPart OverrideContentType
oct),
   ("ContentType", OverrideContentType -> Text
overrideContentTypesType OverrideContentType
oct)]
  ()

contentTypesToElement :: ContentTypes -> Element
contentTypesToElement :: ContentTypes -> Element
contentTypesToElement ct :: ContentTypes
ct =
  let ns :: Text
ns = "http://schemas.openxmlformats.org/package/2006/content-types"
  in
    Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "Types" [("xmlns", Text
ns)] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$

      (DefaultContentType -> Element)
-> [DefaultContentType] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map DefaultContentType -> Element
defaultContentTypeToElem (ContentTypes -> [DefaultContentType]
contentTypesDefaults ContentTypes
ct) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
      (OverrideContentType -> Element)
-> [OverrideContentType] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map OverrideContentType -> Element
overrideContentTypeToElem (ContentTypes -> [OverrideContentType]
contentTypesOverrides ContentTypes
ct)

data DefaultContentType = DefaultContentType
                           { DefaultContentType -> Text
defContentTypesExt :: T.Text
                           , DefaultContentType -> Text
defContentTypesType:: MimeType
                           }
                         deriving (Int -> DefaultContentType -> ShowS
[DefaultContentType] -> ShowS
DefaultContentType -> FilePath
(Int -> DefaultContentType -> ShowS)
-> (DefaultContentType -> FilePath)
-> ([DefaultContentType] -> ShowS)
-> Show DefaultContentType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DefaultContentType] -> ShowS
$cshowList :: [DefaultContentType] -> ShowS
show :: DefaultContentType -> FilePath
$cshow :: DefaultContentType -> FilePath
showsPrec :: Int -> DefaultContentType -> ShowS
$cshowsPrec :: Int -> DefaultContentType -> ShowS
Show, DefaultContentType -> DefaultContentType -> Bool
(DefaultContentType -> DefaultContentType -> Bool)
-> (DefaultContentType -> DefaultContentType -> Bool)
-> Eq DefaultContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultContentType -> DefaultContentType -> Bool
$c/= :: DefaultContentType -> DefaultContentType -> Bool
== :: DefaultContentType -> DefaultContentType -> Bool
$c== :: DefaultContentType -> DefaultContentType -> Bool
Eq)

data OverrideContentType = OverrideContentType
                           { OverrideContentType -> FilePath
overrideContentTypesPart :: FilePath
                           , OverrideContentType -> Text
overrideContentTypesType :: MimeType
                           }
                          deriving (Int -> OverrideContentType -> ShowS
[OverrideContentType] -> ShowS
OverrideContentType -> FilePath
(Int -> OverrideContentType -> ShowS)
-> (OverrideContentType -> FilePath)
-> ([OverrideContentType] -> ShowS)
-> Show OverrideContentType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [OverrideContentType] -> ShowS
$cshowList :: [OverrideContentType] -> ShowS
show :: OverrideContentType -> FilePath
$cshow :: OverrideContentType -> FilePath
showsPrec :: Int -> OverrideContentType -> ShowS
$cshowsPrec :: Int -> OverrideContentType -> ShowS
Show, OverrideContentType -> OverrideContentType -> Bool
(OverrideContentType -> OverrideContentType -> Bool)
-> (OverrideContentType -> OverrideContentType -> Bool)
-> Eq OverrideContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OverrideContentType -> OverrideContentType -> Bool
$c/= :: OverrideContentType -> OverrideContentType -> Bool
== :: OverrideContentType -> OverrideContentType -> Bool
$c== :: OverrideContentType -> OverrideContentType -> Bool
Eq)

data ContentTypes = ContentTypes { ContentTypes -> [DefaultContentType]
contentTypesDefaults :: [DefaultContentType]
                                 , ContentTypes -> [OverrideContentType]
contentTypesOverrides :: [OverrideContentType]
                                 }
                    deriving (Int -> ContentTypes -> ShowS
[ContentTypes] -> ShowS
ContentTypes -> FilePath
(Int -> ContentTypes -> ShowS)
-> (ContentTypes -> FilePath)
-> ([ContentTypes] -> ShowS)
-> Show ContentTypes
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ContentTypes] -> ShowS
$cshowList :: [ContentTypes] -> ShowS
show :: ContentTypes -> FilePath
$cshow :: ContentTypes -> FilePath
showsPrec :: Int -> ContentTypes -> ShowS
$cshowsPrec :: Int -> ContentTypes -> ShowS
Show, ContentTypes -> ContentTypes -> Bool
(ContentTypes -> ContentTypes -> Bool)
-> (ContentTypes -> ContentTypes -> Bool) -> Eq ContentTypes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentTypes -> ContentTypes -> Bool
$c/= :: ContentTypes -> ContentTypes -> Bool
== :: ContentTypes -> ContentTypes -> Bool
$c== :: ContentTypes -> ContentTypes -> Bool
Eq)

contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
contentTypesToEntry :: ContentTypes -> P m Entry
contentTypesToEntry ct :: ContentTypes
ct = FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "[Content_Types].xml" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ ContentTypes -> Element
contentTypesToElement ContentTypes
ct

pathToOverride :: FilePath -> Maybe OverrideContentType
pathToOverride :: FilePath -> Maybe OverrideContentType
pathToOverride fp :: FilePath
fp = FilePath -> Text -> OverrideContentType
OverrideContentType ("/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp) (Text -> OverrideContentType)
-> Maybe Text -> Maybe OverrideContentType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe Text
getContentType FilePath
fp

mediaFileContentType :: FilePath -> Maybe DefaultContentType
mediaFileContentType :: FilePath -> Maybe DefaultContentType
mediaFileContentType fp :: FilePath
fp = case ShowS
takeExtension FilePath
fp of
  '.' : ext :: FilePath
ext -> DefaultContentType -> Maybe DefaultContentType
forall a. a -> Maybe a
Just (DefaultContentType -> Maybe DefaultContentType)
-> DefaultContentType -> Maybe DefaultContentType
forall a b. (a -> b) -> a -> b
$
               DefaultContentType :: Text -> Text -> DefaultContentType
DefaultContentType { defContentTypesExt :: Text
defContentTypesExt = FilePath -> Text
T.pack FilePath
ext
                                  , defContentTypesType :: Text
defContentTypesType =
                                      Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "application/octet-stream" (FilePath -> Maybe Text
getMimeType FilePath
fp)
                                  }
  _ -> Maybe DefaultContentType
forall a. Maybe a
Nothing

mediaContentType :: MediaInfo -> Maybe DefaultContentType
mediaContentType :: MediaInfo -> Maybe DefaultContentType
mediaContentType mInfo :: MediaInfo
mInfo
  | Just t :: Text
t <- MediaInfo -> Maybe Text
mInfoExt MediaInfo
mInfo
  , Just ('.', ext :: Text
ext) <- Text -> Maybe (Char, Text)
T.uncons Text
t =
      DefaultContentType -> Maybe DefaultContentType
forall a. a -> Maybe a
Just (DefaultContentType -> Maybe DefaultContentType)
-> DefaultContentType -> Maybe DefaultContentType
forall a b. (a -> b) -> a -> b
$ DefaultContentType :: Text -> Text -> DefaultContentType
DefaultContentType { defContentTypesExt :: Text
defContentTypesExt = Text
ext
                                , defContentTypesType :: Text
defContentTypesType =
                                    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "application/octet-stream" (MediaInfo -> Maybe Text
mInfoMimeType MediaInfo
mInfo)
                                }
  | Bool
otherwise = Maybe DefaultContentType
forall a. Maybe a
Nothing

getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath]
getSpeakerNotesFilePaths :: P m [FilePath]
getSpeakerNotesFilePaths = do
  Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
  let notesIdNums :: [Int]
notesIdNums = Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map Int Int
mp
  [FilePath] -> P m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> P m [FilePath]) -> [FilePath] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\n :: Int
n -> "ppt/notesSlides/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml")
               [Int]
notesIdNums

presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
presentationToContentTypes :: Presentation -> P m ContentTypes
presentationToContentTypes p :: Presentation
p@(Presentation _ slides :: [Slide]
slides) = do
  [MediaInfo]
mediaInfos <- [[MediaInfo]] -> [MediaInfo]
forall a. Monoid a => [a] -> a
mconcat ([[MediaInfo]] -> [MediaInfo])
-> (Map Int [MediaInfo] -> [[MediaInfo]])
-> Map Int [MediaInfo]
-> [MediaInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int [MediaInfo] -> [[MediaInfo]]
forall k a. Map k a -> [a]
M.elems (Map Int [MediaInfo] -> [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) [MediaInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
  [FilePath]
filePaths <- [Pattern] -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths ([Pattern] -> P m [FilePath]) -> [Pattern] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ Presentation -> [Pattern]
inheritedPatterns Presentation
p
  let mediaFps :: [FilePath]
mediaFps = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match (FilePath -> Pattern
compile "ppt/media/image*")) [FilePath]
filePaths
  let defaults :: [DefaultContentType]
defaults = [ Text -> Text -> DefaultContentType
DefaultContentType "xml" "application/xml"
                 , Text -> Text -> DefaultContentType
DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
                 ]
      mediaDefaults :: [DefaultContentType]
mediaDefaults = [DefaultContentType] -> [DefaultContentType]
forall a. Eq a => [a] -> [a]
nub ([DefaultContentType] -> [DefaultContentType])
-> [DefaultContentType] -> [DefaultContentType]
forall a b. (a -> b) -> a -> b
$
                      (MediaInfo -> Maybe DefaultContentType)
-> [MediaInfo] -> [DefaultContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MediaInfo -> Maybe DefaultContentType
mediaContentType [MediaInfo]
mediaInfos [DefaultContentType]
-> [DefaultContentType] -> [DefaultContentType]
forall a. Semigroup a => a -> a -> a
<>
                      (FilePath -> Maybe DefaultContentType)
-> [FilePath] -> [DefaultContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe DefaultContentType
mediaFileContentType [FilePath]
mediaFps

      inheritedOverrides :: [OverrideContentType]
inheritedOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride [FilePath]
filePaths
      createdOverrides :: [OverrideContentType]
createdOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride [ "docProps/core.xml"
                                                 , "docProps/custom.xml"
                                                 , "ppt/presentation.xml"
                                                 , "ppt/viewProps.xml"
                                                 ]
  [FilePath]
relativePaths <- (Slide -> ReaderT WriterEnv (StateT WriterState m) FilePath)
-> [Slide] -> P m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) FilePath
forall (m :: * -> *). PandocMonad m => Slide -> P m FilePath
slideToFilePath [Slide]
slides
  let slideOverrides :: [OverrideContentType]
slideOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                       (\fp :: FilePath
fp -> FilePath -> Maybe OverrideContentType
pathToOverride (FilePath -> Maybe OverrideContentType)
-> FilePath -> Maybe OverrideContentType
forall a b. (a -> b) -> a -> b
$ "ppt/slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp)
                       [FilePath]
relativePaths
  [OverrideContentType]
speakerNotesOverrides <- (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride ([FilePath] -> [OverrideContentType])
-> P m [FilePath]
-> ReaderT WriterEnv (StateT WriterState m) [OverrideContentType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P m [FilePath]
forall (m :: * -> *). PandocMonad m => P m [FilePath]
getSpeakerNotesFilePaths
  ContentTypes -> P m ContentTypes
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentTypes -> P m ContentTypes)
-> ContentTypes -> P m ContentTypes
forall a b. (a -> b) -> a -> b
$ [DefaultContentType] -> [OverrideContentType] -> ContentTypes
ContentTypes
    ([DefaultContentType]
defaults [DefaultContentType]
-> [DefaultContentType] -> [DefaultContentType]
forall a. Semigroup a => a -> a -> a
<> [DefaultContentType]
mediaDefaults)
    ([OverrideContentType]
inheritedOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
createdOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
slideOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
speakerNotesOverrides)

presML :: T.Text
presML :: Text
presML = "application/vnd.openxmlformats-officedocument.presentationml"

noPresML :: T.Text
noPresML :: Text
noPresML = "application/vnd.openxmlformats-officedocument"

getContentType :: FilePath -> Maybe MimeType
getContentType :: FilePath -> Maybe Text
getContentType fp :: FilePath
fp
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/presentation.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".presentation.main+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/presProps.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".presProps+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/viewProps.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".viewProps+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/tableStyles.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".tableStyles+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/core.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just "application/vnd.openxmlformats-package.core-properties+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/custom.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just "application/vnd.openxmlformats-officedocument.custom-properties+xml"
  | FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/app.xml" = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
noPresML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".extended-properties+xml"
  | ["ppt", "slideMasters", f :: FilePath
f] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
  , (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".slideMaster+xml"
  | ["ppt", "slides", f :: FilePath
f] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
  , (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".slide+xml"
  | ["ppt", "notesMasters", f :: FilePath
f] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
  , (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".notesMaster+xml"
  | ["ppt", "notesSlides", f :: FilePath
f] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
  , (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".notesSlide+xml"
  | ["ppt", "theme", f :: FilePath
f] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
  , (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
noPresML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".theme+xml"
  | ["ppt", "slideLayouts", _] <- FilePath -> [FilePath]
splitDirectories FilePath
fp=
      Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
presML Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".slideLayout+xml"
  | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

-- Kept as String for XML.Light
autoNumAttrs :: ListAttributes -> [(Text, Text)]
autoNumAttrs :: ListAttributes -> NameSpaces
autoNumAttrs (startNum :: Int
startNum, numStyle :: ListNumberStyle
numStyle, numDelim :: ListNumberDelim
numDelim) =
  NameSpaces
numAttr NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<> NameSpaces
typeAttr
  where
    numAttr :: NameSpaces
numAttr = [("startAt", Int -> Text
forall a. Show a => a -> Text
tshow Int
startNum) | Int
startNum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 1]
    typeAttr :: NameSpaces
typeAttr = [("type", Text
typeString Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
delimString)]
    typeString :: Text
typeString = case ListNumberStyle
numStyle of
      Decimal -> "arabic"
      UpperAlpha -> "alphaUc"
      LowerAlpha -> "alphaLc"
      UpperRoman -> "romanUc"
      LowerRoman -> "romanLc"
      _          -> "arabic"
    delimString :: Text
delimString = case ListNumberDelim
numDelim of
      Period -> "Period"
      OneParen -> "ParenR"
      TwoParens -> "ParenBoth"
      _         -> "Period"

-- | The XML required to insert an "appear" animation for each of the given
-- groups of paragraphs, identified by index.
incrementalAnimation ::
  -- | (ShapeId, [(startParagraphIndex, endParagraphIndex)])
  NonEmpty (ShapeId, NonEmpty (Integer, Integer)) ->
  Element
incrementalAnimation :: NonEmpty (Pixels, NonEmpty (Pixels, Pixels)) -> Element
incrementalAnimation indices :: NonEmpty (Pixels, NonEmpty (Pixels, Pixels))
indices = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:timing" [] [Element
tnLst, Element
bldLst]
  where
    triples :: NonEmpty (ShapeId, Integer, Integer)
    triples :: NonEmpty (Pixels, Pixels, Pixels)
triples = do
      (shapeId :: Pixels
shapeId, paragraphIds :: NonEmpty (Pixels, Pixels)
paragraphIds) <- NonEmpty (Pixels, NonEmpty (Pixels, Pixels))
indices
      (start :: Pixels
start, end :: Pixels
end) <- NonEmpty (Pixels, Pixels)
paragraphIds
      (Pixels, Pixels, Pixels) -> NonEmpty (Pixels, Pixels, Pixels)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pixels
shapeId, Pixels
start, Pixels
end)

    tnLst :: Element
tnLst = Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:tnLst" []
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:par" []
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [ ("id", "1")
                       , ("dur", "indefinite")
                       , ("restart", "never")
                       , ("nodeType", "tmRoot")
                       ]
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:childTnLst" []
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:seq" [ ("concurrent", "1")
                       , ("nextAc", "seek")
                       ]
      [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [ ("id", "2")
                       , ("dur", "indefinite")
                       , ("nodeType", "mainSeq")
                       ]
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:childTnLst" []
        ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (Pixels -> (Pixels, Pixels, Pixels) -> Element)
-> [Pixels] -> [(Pixels, Pixels, Pixels)] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pixels -> (Pixels, Pixels, Pixels) -> Element
makePar [3, 7 ..] (NonEmpty (Pixels, Pixels, Pixels) -> [(Pixels, Pixels, Pixels)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Pixels, Pixels, Pixels)
triples)
      , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:prevCondLst" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" ([("evt", "onPrev"), ("delay", "0")])
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:tgtEl" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sldTgt" [] ()
      , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:nextCondLst" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" ([("evt", "onNext"), ("delay", "0")])
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:tgtEl" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:sldTgt" [] ()
      ]
    bldLst :: Element
bldLst = Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:bldLst" []
      [ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:bldP" [ ("spid", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
shapeId))
                        , ("grpId", "0")
                        , ("uiExpand", "1")
                        , ("build", "p")
                        ]
        () | (shapeId :: Pixels
shapeId, _) <- NonEmpty (Pixels, NonEmpty (Pixels, Pixels))
-> [(Pixels, NonEmpty (Pixels, Pixels))]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Pixels, NonEmpty (Pixels, Pixels))
indices
      ]

    makePar :: Integer -> (ShapeId, Integer, Integer) -> Element
    makePar :: Pixels -> (Pixels, Pixels, Pixels) -> Element
makePar nextId :: Pixels
nextId (shapeId :: Pixels
shapeId, start :: Pixels
start, end :: Pixels
end) =
      Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:par" []
        (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [("id", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
nextId)), ("fill", "hold")]
        [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:stCondLst" []
          (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" [("delay", "indefinite")] ()
        , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:childTnLst" []
          (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:par" []
          (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [ ("id", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels
nextId Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
+ 1)))
                           , ("fill", "hold")
                           ]
          [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:stCondLst" []
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" [("delay", "0")] ()
          , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:childTnLst" []
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:par" []
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [ ("id", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels
nextId Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
+ 2)))
                             , ("presetID", "1")
                             , ("presetClass", "entr")
                             , ("presetSubtype", "0")
                             , ("fill", "hold")
                             , ("grpId", "0")
                             , ("nodeType", "clickEffect")
                             ]
            [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:stCondLst" []
              (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" [("delay", "0")] ()
            , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:childTnLst" []
              (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:set" []
              [ Text -> NameSpaces -> [Element] -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cBhvr" []
                [ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cTn" [ ("id", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels
nextId Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
+ 3)))
                                 , ("dur", "1")
                                 , ("fill", "hold")
                                 ]
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:stCondLst" []
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:cond" [("delay", "0")] ()
                , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:tgtEl" []
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:spTgt" [("spid", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
shapeId))]
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:txEl" []
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:pRg" [ ("st", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
start))
                                   , ("end", FilePath -> Text
T.pack (Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
end))]
                    ()
                , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:attrNameLst" []
                  (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> Text -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:attrName" [] ("style.visibility" :: Text)
                ]
              , Text -> NameSpaces -> Element -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:to" []
                (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> NameSpaces -> () -> Element
forall t. Node t => Text -> NameSpaces -> t -> Element
mknode "p:strVal" [("val", "visible")] ()
              ]
            ]
          ]
        ]