Powerpoint writer: Refactor into separate modules.

There are two steps in the conversion: a conversion from pandoc to a
Presentation datatype modeling pptx, and a conversion from
Presentation to a pptx archive. The two steps were sharing the same
state and environment, and the code was getting a bit
spaghetti-ish. This separates the conversion into separate
modules (T.P.W.Powerpoint.Presentation, which defineds the
Presentation datatype and goes Pandoc->Presentation)
and (T.P.W.Pandoc.Output, which goes Presentation->Archive).
Text.Pandoc.Writers.Powerpoint a thin wrapper around the two modules.

3 files changed, 2151 insertions, 1979 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs
index 647c37a0b..3d6b736f2 100644
--- a/src/Text/Pandoc/Writers/Powerpoint.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
 
 {-
 Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -27,44 +27,29 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    Stability   : alpha
    Portability : portable
 
-Conversion of 'Pandoc' documents to powerpoint (pptx).
+Conversion of 'Pandoc' documents to powerpoint (pptx). -}
+
+{-
+This is a wrapper around two modules:
+
+  - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a
+    pandoc document into a Presentation datatype), and
+
+  - Text.Pandoc.Writers.Powerpoint.Output (which converts a
+    Presentation into a zip archive, which can be output).
 -}
 
 module Text.Pandoc.Writers.Powerpoint (writePowerpoint) 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)
-import Data.Default
-import Data.Time.Clock (UTCTime)
-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
-import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
-import Text.XML.Light
 import Text.Pandoc.Definition
-import qualified Text.Pandoc.UTF8 as UTF8
+import Text.Pandoc.Walk
 import Text.Pandoc.Class (PandocMonad)
-import Text.Pandoc.Error (PandocError(..))
-import Text.Pandoc.Slides (getSlideLevel)
-import qualified Text.Pandoc.Class as P
-import Text.Pandoc.Options
-import Text.Pandoc.MIME
-import Text.Pandoc.Logging
+import Text.Pandoc.Options (WriterOptions)
+import Text.Pandoc.Writers.Shared (fixDisplayMath)
+import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation)
+import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive)
 import qualified Data.ByteString.Lazy as BL
-import Text.Pandoc.Walk
-import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
-import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines)
-import Text.Pandoc.Writers.OOXML
-import qualified Data.Map as M
-import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)
-import Text.Pandoc.ImageSize
-import Control.Applicative ((<|>))
-import System.FilePath.Glob
-
-import Text.TeXMath
-import Text.Pandoc.Writers.Math (convertMath)
-
 
 writePowerpoint :: (PandocMonad m)
                 => WriterOptions  -- ^ Writer options
@@ -72,1951 +57,6 @@ writePowerpoint :: (PandocMonad m)
                 -> m BL.ByteString
 writePowerpoint opts (Pandoc meta blks) = do
   let blks' = walk fixDisplayMath blks
-  distArchive <- (toArchive . BL.fromStrict) <$>
-                      P.readDefaultDataFile "reference.pptx"
-  refArchive <- case writerReferenceDoc opts of
-                     Just f  -> toArchive <$> P.readFileLazy f
-                     Nothing -> (toArchive . BL.fromStrict) <$>
-                        P.readDataFile "reference.pptx"
-
-  utctime <- P.getCurrentTime
-
-  presSize <- case getPresentationSize refArchive distArchive of
-                Just sz -> return sz
-                Nothing -> throwError $
-                           PandocSomeError $
-                           "Could not determine presentation size"
-
-  let env = def { envMetadata = meta
-                , envRefArchive = refArchive
-                , envDistArchive = distArchive
-                , envUTCTime = utctime
-                , envOpts = opts
-                , envSlideLevel = case writerSlideLevel opts of
-                                    Just n -> n
-                                    Nothing -> getSlideLevel blks'
-                , envPresentationSize = presSize
-                }
-
-  let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
-               }
-
-  runP env st $ do pres <- blocksToPresentation blks'
-                   archv <- presentationToArchive pres
-                   return $ fromArchive archv
-
-concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
-concatMapM f xs   =  liftM concat (mapM f xs)
-
-data WriterEnv = WriterEnv { envMetadata :: Meta
-                           , envRunProps :: RunProps
-                           , envParaProps :: ParaProps
-                           , envSlideLevel :: Int
-                           , envRefArchive :: Archive
-                           , envDistArchive :: Archive
-                           , envUTCTime :: UTCTime
-                           , envOpts :: WriterOptions
-                           , envPresentationSize :: (Integer, Integer)
-                           , envSlideHasHeader :: Bool
-                           , envInList :: Bool
-                           , envInNoteSlide :: Bool
-                           , envCurSlideId :: Int
-                           -- the difference between the number at
-                           -- the end of the slide file name and
-                           -- the rId number
-                           , envSlideIdOffset :: Int
-                           , envContentType :: ContentType
-                           }
-                 deriving (Show)
-
-instance Default WriterEnv where
-  def = WriterEnv { envMetadata = mempty
-                  , envRunProps = def
-                  , envParaProps = def
-                  , envSlideLevel = 2
-                  , envRefArchive = emptyArchive
-                  , envDistArchive = emptyArchive
-                  , envUTCTime = posixSecondsToUTCTime 0
-                  , envOpts = def
-                  , envPresentationSize = (720, 540)
-                  , envSlideHasHeader = False
-                  , envInList = False
-                  , envInNoteSlide = False
-                  , envCurSlideId = 1
-                  , envSlideIdOffset = 1
-                  , envContentType = NormalContent
-                  }
-
-data ContentType = NormalContent
-                 | TwoColumnLeftContent
-                 | TwoColumnRightContent
-                 deriving (Show, Eq)
-
-data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
-                           , mInfoLocalId  :: Int
-                           , mInfoGlobalId :: Int
-                           , mInfoMimeType :: Maybe MimeType
-                           , mInfoExt      :: Maybe String
-                           , mInfoCaption  :: Bool
-                           } deriving (Show, Eq)
-
-data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String))
-                               -- (FP, Local ID, Global ID, Maybe Mime)
-                               , stMediaIds :: M.Map Int [MediaInfo]
-                               , stMediaGlobalIds :: M.Map FilePath Int
-                               , stNoteIds :: M.Map Int [Block]
-                               -- associate anchors with slide id
-                               , stAnchorMap :: M.Map String Int
-                               -- media inherited from the template.
-                               , stTemplateMedia :: [FilePath]
-                               } deriving (Show, Eq)
-
-instance Default WriterState where
-  def = WriterState { stLinkIds = mempty
-                    , stMediaIds = mempty
-                    , stMediaGlobalIds = mempty
-                    , stNoteIds = mempty
-                    , stAnchorMap= mempty
-                    , stTemplateMedia = []
-                    }
-
--- 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 refArchive distArchive =
-  let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
-      mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles
-
-      go :: FilePath -> Maybe (FilePath, Int)
-      go fp = do
-        s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp
-        (n, _) <- listToMaybe $ reads s
-        return (fp, n)
-  in
-    M.fromList $ mapMaybe go mediaPaths
-
-getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)
-getPresentationSize refArchive distArchive = do
-  entry <- findEntryByPath "ppt/presentation.xml" refArchive  `mplus`
-           findEntryByPath "ppt/presentation.xml" distArchive
-  presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry
-  let ns = elemToNameSpaces presElement
-  sldSize <- findChild (elemName ns "p" "sldSz") presElement
-  cxS <- findAttr (QName "cx" Nothing Nothing) sldSize
-  cyS <- findAttr (QName "cy" Nothing Nothing) sldSize
-  (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)
-  (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)
-  return (cx `div` 12700, cy `div` 12700)
-
-type P m = ReaderT WriterEnv (StateT WriterState m)
-
-runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
-runP env st p = evalStateT (runReaderT p env) st
-
-type Pixels = Integer
-
-data Presentation = Presentation [Slide]
-  deriving (Show)
-
-data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
-                            , metadataSlideSubtitle :: [ParaElem]
-                            , metadataSlideAuthors :: [[ParaElem]]
-                            , metadataSlideDate :: [ParaElem]
-                            }
-           | TitleSlide { titleSlideHeader :: [ParaElem]}
-           | ContentSlide { contentSlideHeader :: [ParaElem]
-                          , contentSlideContent :: [Shape]
-                          }
-           | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]
-                            , twoColumnSlideLeft   :: [Shape]
-                            , twoColumnSlideRight  :: [Shape]
-                            }
-           deriving (Show, Eq)
-
-data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape
-  deriving (Show, Eq)
-
-data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]
-           | GraphicFrame [Graphic] [ParaElem]
-           | TextBox [Paragraph]
-  deriving (Show, Eq)
-
-type Cell = [Paragraph]
-
-data TableProps = TableProps { tblPrFirstRow :: Bool
-                             , tblPrBandRow :: Bool
-                             } deriving (Show, Eq)
-
-type ColWidth = Integer
-
-data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]]
-  deriving (Show, Eq)
-
-
-data Paragraph = Paragraph { paraProps :: ParaProps
-                           , paraElems  :: [ParaElem]
-                           } deriving (Show, Eq)
-
-autoNumberingToType :: ListAttributes -> String
-autoNumberingToType (_, numStyle, numDelim) =
-  typeString ++ delimString
-  where
-    typeString = case numStyle of
-      Decimal -> "arabic"
-      UpperAlpha -> "alphaUc"
-      LowerAlpha -> "alphaLc"
-      UpperRoman -> "romanUc"
-      LowerRoman -> "romanLc"
-      _          -> "arabic"
-    delimString = case numDelim of
-      Period -> "Period"
-      OneParen -> "ParenR"
-      TwoParens -> "ParenBoth"
-      _         -> "Period"
-
-data BulletType = Bullet
-                | AutoNumbering ListAttributes
-  deriving (Show, Eq)
-
-data Algnment = AlgnLeft | AlgnRight | AlgnCenter
-  deriving (Show, Eq)
-
-data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels
-                           , pPropMarginRight :: Maybe Pixels
-                           , pPropLevel :: Int
-                           , pPropBullet :: Maybe BulletType
-                           , pPropAlign :: Maybe Algnment
-                           , pPropSpaceBefore :: Maybe Pixels
-                           } deriving (Show, Eq)
-
-instance Default ParaProps where
-  def = ParaProps { pPropMarginLeft = Just 0
-                  , pPropMarginRight = Just 0
-                  , pPropLevel = 0
-                  , pPropBullet = Nothing
-                  , pPropAlign = Nothing
-                  , pPropSpaceBefore = Nothing
-                  }
-
-newtype TeXString = TeXString {unTeXString :: String}
-  deriving (Eq, Show)
-
-data ParaElem = Break
-              | Run RunProps String
-              -- It would be more elegant to have native TeXMath
-              -- Expressions here, but this allows us to use
-              -- `convertmath` from T.P.Writers.Math. Will perhaps
-              -- revisit in the future.
-              | MathElem MathType TeXString
-              deriving (Show, Eq)
-
-data Strikethrough = NoStrike | SingleStrike | DoubleStrike
-  deriving (Show, Eq)
-
-data Capitals = NoCapitals | SmallCapitals | AllCapitals
-  deriving (Show, Eq)
-
-type URL = String
-
-data RunProps = RunProps { rPropBold :: Bool
-                         , rPropItalics :: Bool
-                         , rStrikethrough :: Maybe Strikethrough
-                         , rBaseline :: Maybe Int
-                         , rCap :: Maybe Capitals
-                         , rLink :: Maybe (URL, String)
-                         , rPropCode :: Bool
-                         , rPropBlockQuote :: Bool
-                         , rPropForceSize :: Maybe Pixels
-                         } deriving (Show, Eq)
-
-instance Default RunProps where
-  def = RunProps { rPropBold = False
-                 , rPropItalics = False
-                 , rStrikethrough = Nothing
-                 , rBaseline = Nothing
-                 , rCap = Nothing
-                 , rLink = Nothing
-                 , rPropCode = False
-                 , rPropBlockQuote = False
-                 , rPropForceSize = Nothing
-                 }
-
-data PicProps = PicProps { picPropLink :: Maybe (URL, String)
-                         } deriving (Show, Eq)
-
-instance Default PicProps where
-  def = PicProps { picPropLink = Nothing
-                 }
-
---------------------------------------------------
-
-inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem]
-inlinesToParElems ils = concatMapM inlineToParElems ils
-
-inlineToParElems :: Monad m => Inline -> P m [ParaElem]
-inlineToParElems (Str s) = do
-  pr <- asks envRunProps
-  return [Run pr s]
-inlineToParElems (Emph ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $
-  inlinesToParElems ils
-inlineToParElems (Strong ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $
-  inlinesToParElems ils
-inlineToParElems (Strikeout ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $
-  inlinesToParElems ils
-inlineToParElems (Superscript ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $
-  inlinesToParElems ils
-inlineToParElems (Subscript ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $
-  inlinesToParElems ils
-inlineToParElems (SmallCaps ils) =
-  local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $
-  inlinesToParElems ils
-inlineToParElems Space = inlineToParElems (Str " ")
-inlineToParElems SoftBreak = inlineToParElems (Str " ")
-inlineToParElems LineBreak = return [Break]
-inlineToParElems (Link _ ils (url, title)) = do
-  local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $
-    inlinesToParElems ils
-inlineToParElems (Code _ str) = do
-  local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $
-    inlineToParElems $ Str str
-inlineToParElems (Math mathtype str) =
-  return [MathElem mathtype (TeXString str)]
-inlineToParElems (Note blks) = do
-  notes <- gets stNoteIds
-  let maxNoteId = case M.keys notes of
-        [] -> 0
-        lst -> maximum lst
-      curNoteId = maxNoteId + 1
-  modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }
-  inlineToParElems $ Superscript [Str $ show curNoteId]
-inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils
-inlineToParElems (RawInline _ _) = return []
-inlineToParElems _ = return []
-
-isListType :: Block -> Bool
-isListType (OrderedList _ _) = True
-isListType (BulletList _) = True
-isListType (DefinitionList _) = True
-isListType _ = False
-
-registerAnchorId :: PandocMonad m => String -> P m ()
-registerAnchorId anchor = do
-  anchorMap <- gets stAnchorMap
-  slideId <- asks envCurSlideId
-  unless (null anchor) $
-    modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
-
-blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]
-blockToParagraphs (Plain ils) = do
-  parElems <- inlinesToParElems ils
-  pProps <- asks envParaProps
-  return [Paragraph pProps parElems]
-blockToParagraphs (Para ils) = do
-  parElems <- inlinesToParElems ils
-  pProps <- asks envParaProps
-  return [Paragraph pProps parElems]
-blockToParagraphs (LineBlock ilsList) = do
-  parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList
-  pProps <- asks envParaProps
-  return [Paragraph pProps parElems]
--- TODO: work out the attributes
-blockToParagraphs (CodeBlock attr str) =
-  local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $
-  blockToParagraphs $ Para [Code attr str]
--- We can't yet do incremental lists, but we should render a
--- (BlockQuote List) as a list to maintain compatibility with other
--- formats.
-blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do
-  ps  <- blockToParagraphs blk
-  ps' <- blockToParagraphs $ BlockQuote blks
-  return $ ps ++ ps'
-blockToParagraphs (BlockQuote blks) =
-  local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
-                , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$
-  concatMapM blockToParagraphs blks
--- TODO: work out the format
-blockToParagraphs (RawBlock _ _) = return []
-blockToParagraphs (Header _ (ident, _, _) ils) = do
-  -- Note that this function only deals with content blocks, so it
-  -- will only touch headers that are above the current slide level --
-  -- slides at or below the slidelevel will be taken care of by
-  -- `blocksToSlide'`. We have the register anchors in both of them.
-  registerAnchorId ident
-  -- we set the subeader to bold
-  parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $
-              inlinesToParElems ils
-  -- and give it a bit of space before it.
-  return [Paragraph def{pPropSpaceBefore = Just 30} parElems]
-blockToParagraphs (BulletList blksLst) = do
-  pProps <- asks envParaProps
-  let lvl = pPropLevel pProps
-  local (\env -> env{ envInList = True
-                    , envParaProps = pProps{ pPropLevel = lvl + 1
-                                           , pPropBullet = Just Bullet
-                                           , pPropMarginLeft = Nothing
-                                           }}) $
-    concatMapM multiParBullet blksLst
-blockToParagraphs (OrderedList listAttr blksLst) = do
-  pProps <- asks envParaProps
-  let lvl = pPropLevel pProps
-  local (\env -> env{ envInList = True
-                    , envParaProps = pProps{ pPropLevel = lvl + 1
-                                           , pPropBullet = Just (AutoNumbering listAttr)
-                                           , pPropMarginLeft = Nothing
-                                           }}) $
-    concatMapM multiParBullet blksLst
-blockToParagraphs (DefinitionList entries) = do
-  let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph]
-      go (ils, blksLst) = do
-        term <-blockToParagraphs $ Para [Strong ils]
-        -- For now, we'll treat each definition term as a
-        -- blockquote. We can extend this further later.
-        definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst
-        return $ term ++ definition
-  concatMapM go entries
-blockToParagraphs (Div (_, ("notes" : []), _) _) = return []
-blockToParagraphs (Div _ blks)  = concatMapM blockToParagraphs blks
-blockToParagraphs blk = do
-  P.report $ BlockNotRendered blk
-  return []
-
--- Make sure the bullet env gets turned off after the first para.
-multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph]
-multiParBullet [] = return []
-multiParBullet (b:bs) = do
-  pProps <- asks envParaProps
-  p <- blockToParagraphs b
-  ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $
-    concatMapM blockToParagraphs bs
-  return $ p ++ ps
-
-cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph]
-cellToParagraphs algn tblCell = do
-  paras <- mapM (blockToParagraphs) tblCell
-  let alignment = case algn of
-        AlignLeft -> Just AlgnLeft
-        AlignRight -> Just AlgnRight
-        AlignCenter -> Just AlgnCenter
-        AlignDefault -> Nothing
-      paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
-  return $ concat paras'
-
-rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]]
-rowToParagraphs algns tblCells = do
-  -- We have to make sure we have the right number of alignments
-  let pairs = zip (algns ++ repeat AlignDefault) tblCells
-  mapM (\(a, tc) -> cellToParagraphs a tc) pairs
-
-blockToShape :: PandocMonad m => Block -> P m Shape
-blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =
-      Pic def url attr <$> (inlinesToParElems ils)
-blockToShape (Para (il:_))  | Image attr ils (url, _) <- il =
-      Pic def url attr <$> (inlinesToParElems ils)
-blockToShape (Plain (il:_)) | Link _ (il':_) target <- il
-                            , Image attr ils (url, _) <- il' =
-      Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
-blockToShape (Para (il:_))  | Link _ (il':_) target <- il
-                            , Image attr ils (url, _) <- il' =
-      Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
-blockToShape (Table caption algn _ hdrCells rows) = do
-  caption' <- inlinesToParElems caption
-  (pageWidth, _) <- asks envPresentationSize
-  hdrCells' <- rowToParagraphs algn hdrCells
-  rows' <- mapM (rowToParagraphs algn) rows
-  let tblPr = if null hdrCells
-              then TableProps { tblPrFirstRow = False
-                              , tblPrBandRow = True
-                              }
-              else TableProps { tblPrFirstRow = True
-                              , tblPrBandRow = True
-                              }
-      colWidths = if null hdrCells
-                 then case rows of
-                        r : _ | not (null r) -> replicate (length r) $
-                                                (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length 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 replicate (length hdrCells) $
-                      (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)
-
-  return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption'
-blockToShape blk = TextBox <$> blockToParagraphs blk
-
-blocksToShapes :: PandocMonad m => [Block] -> P m [Shape]
-blocksToShapes blks = combineShapes <$> mapM blockToShape blks
-
-isImage :: Inline -> Bool
-isImage (Image _ _ _) = True
-isImage (Link _ ((Image _ _ _) : _) _) = True
-isImage _ = False
-
-splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]]
-splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])
-splitBlocks' cur acc (HorizontalRule : blks) =
-  splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks
-splitBlocks' cur acc (h@(Header n _ _) : blks) = do
-  slideLevel <- asks envSlideLevel
-  case compare n slideLevel of
-    LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks
-    EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks
-    GT -> splitBlocks' (cur ++ [h]) acc blks
--- `blockToParagraphs` treats Plain and Para the same, so we can save
--- some code duplication by treating them the same here.
-splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)
-splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do
-  slideLevel <- asks envSlideLevel
-  case cur of
-    (Header n _ _) : [] | n == slideLevel ->
-                            splitBlocks' []
-                            (acc ++ [cur ++ [Para [il]]])
-                            (if null ils then blks else (Para ils) : blks)
-    _ -> splitBlocks' []
-         (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])
-         (if null ils then blks else (Para ils) : blks)
-splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do
-  slideLevel <- asks envSlideLevel
-  case cur of
-    (Header n _ _) : [] | n == slideLevel ->
-                            splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks
-    _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks
-splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes =  do
-  slideLevel <- asks envSlideLevel
-  case cur of
-    (Header n _ _) : [] | n == slideLevel ->
-                            splitBlocks' [] (acc ++ [cur ++ [d]]) blks
-    _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks
-splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks
-
-splitBlocks :: Monad m => [Block] -> P m [[Block]]
-splitBlocks = splitBlocks' [] []
-
-blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide
-blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
-  | n < lvl = do
-      registerAnchorId ident
-      hdr <- inlinesToParElems ils
-      return $ TitleSlide {titleSlideHeader = hdr}
-  | n == lvl = do
-      registerAnchorId ident
-      hdr <- inlinesToParElems ils
-      -- Now get the slide without the header, and then add the header
-      -- in.
-      slide <- blocksToSlide' lvl blks
-      return $ case slide of
-        ContentSlide _ cont          -> ContentSlide hdr cont
-        TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
-        slide'                       -> slide'
-blocksToSlide' _ (blk : blks)
-  | Div (_, classes, _) divBlks <- blk
-  , "columns" `elem` classes
-  , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks
-  , "column" `elem` clsL, "column" `elem` clsR = do
-      unless (null blks)
-        (mapM (P.report . BlockNotRendered) blks >> return ())
-      unless (null remaining)
-        (mapM (P.report . BlockNotRendered) remaining >> return ())
-      mbSplitBlksL <- splitBlocks blksL
-      mbSplitBlksR <- splitBlocks blksR
-      let blksL' = case mbSplitBlksL of
-            bs : _ -> bs
-            []     -> []
-      let blksR' = case mbSplitBlksR of
-            bs : _ -> bs
-            []     -> []
-      shapesL <- blocksToShapes blksL'
-      shapesR <- blocksToShapes blksR'
-      return $ TwoColumnSlide { twoColumnSlideHeader = []
-                              , twoColumnSlideLeft = shapesL
-                              , twoColumnSlideRight = shapesR
-                              }
-blocksToSlide' _ (blk : blks) = do
-      inNoteSlide <- asks envInNoteSlide
-      shapes <- if inNoteSlide
-                then forceFontSize noteSize $ blocksToShapes (blk : blks)
-                else blocksToShapes (blk : blks)
-      return $ ContentSlide { contentSlideHeader = []
-                            , contentSlideContent = shapes
-                            }
-blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []
-                                            , contentSlideContent = []
-                                            }
-
-blocksToSlide :: PandocMonad m => [Block] -> P m Slide
-blocksToSlide blks = do
-  slideLevel <- asks envSlideLevel
-  blocksToSlide' slideLevel blks
-
-makeNoteEntry :: Int -> [Block] -> [Block]
-makeNoteEntry n blks =
-  let enum = Str (show n ++ ".")
-  in
-    case blks of
-      (Para ils : blks') -> (Para $ enum : Space : ils) : blks'
-      _ -> (Para [enum]) : blks
-
-forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a
-forceFontSize px x = do
-  rpr <- asks envRunProps
-  local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x
-
--- We leave these as blocks because we will want to include them in
--- the TOC.
-makeNotesSlideBlocks :: PandocMonad m => P m [Block]
-makeNotesSlideBlocks = do
-  noteIds <- gets stNoteIds
-  slideLevel <- asks envSlideLevel
-  meta <- asks envMetadata
-  -- Get identifiers so we can give the notes section a unique ident.
-  anchorSet <- M.keysSet <$> gets stAnchorMap
-  if M.null noteIds
-    then return []
-    else do let title = case lookupMeta "notes-title" meta of
-                  Just val -> metaValueToInlines val
-                  Nothing  -> [Str "Notes"]
-                ident = Shared.uniqueIdent title anchorSet
-                hdr = Header slideLevel (ident, [], []) title
-            blks <- return $
-                    concatMap (\(n, bs) -> makeNoteEntry n bs) $
-                    M.toList noteIds
-            return $ hdr : blks
-
-getMetaSlide :: PandocMonad m => P m (Maybe Slide)
-getMetaSlide  = do
-  meta <- asks envMetadata
-  title <- inlinesToParElems $ docTitle meta
-  subtitle <- inlinesToParElems $
-    case lookupMeta "subtitle" meta of
-      Just (MetaString s)           -> [Str s]
-      Just (MetaInlines ils)        -> ils
-      Just (MetaBlocks [Plain ils]) -> ils
-      Just (MetaBlocks [Para ils])  -> ils
-      _                             -> []
-  authors <- mapM inlinesToParElems $ docAuthors meta
-  date <- inlinesToParElems $ docDate meta
-  if null title && null subtitle && null authors && null date
-    then return Nothing
-    else return $ Just $ MetadataSlide { metadataSlideTitle = title
-                                       , metadataSlideSubtitle = subtitle
-                                       , metadataSlideAuthors = authors
-                                       , metadataSlideDate = date
-                                       }
-
--- adapted from the markdown writer
-elementToListItem :: PandocMonad m => Shared.Element -> P m [Block]
-elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do
-  opts <- asks envOpts
-  let headerLink = if null ident
-                   then walk Shared.deNote headerText
-                   else [Link nullAttr (walk Shared.deNote headerText)
-                          ('#':ident, "")]
-  listContents <- if null subsecs || lev >= writerTOCDepth opts
-                  then return []
-                  else mapM elementToListItem subsecs
-  return [Plain headerLink, BulletList listContents]
-elementToListItem (Shared.Blk _) = return []
-
-makeTOCSlide :: PandocMonad m => [Block] -> P m Slide
-makeTOCSlide blks = do
-  contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)
-  meta <- asks envMetadata
-  slideLevel <- asks envSlideLevel
-  let tocTitle = case lookupMeta "toc-title" meta of
-                   Just val -> metaValueToInlines val
-                   Nothing  -> [Str "Table of Contents"]
-      hdr = Header slideLevel nullAttr tocTitle
-  sld <- blocksToSlide [hdr, contents]
-  return sld
-
-blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation
-blocksToPresentation blks = do
-  opts <- asks envOpts
-  let metadataStartNum = 1
-  metadataslides <- maybeToList <$> getMetaSlide
-  let tocStartNum = metadataStartNum + length metadataslides
-  -- As far as I can tell, if we want to have a variable-length toc in
-  -- the future, we'll have to make it twice. Once to get the length,
-  -- and a second time to include the notes slide. We can't make the
-  -- notes slide before the body slides because we need to know if
-  -- there are notes, and we can't make either before the toc slide,
-  -- because we need to know its length to get slide numbers right.
-  --
-  -- For now, though, since the TOC slide is only length 1, if it
-  -- exists, we'll just get the length, and then come back to make the
-  -- slide later
-  let tocSlidesLength = if writerTableOfContents opts then 1 else 0
-  let bodyStartNum = tocStartNum + tocSlidesLength
-  blksLst <- splitBlocks blks
-  bodyslides <- mapM
-                (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs))
-                (zip blksLst [bodyStartNum..])
-  let noteStartNum = bodyStartNum + length bodyslides
-  notesSlideBlocks <- makeNotesSlideBlocks
-  -- now we come back and make the real toc...
-  tocSlides <- if writerTableOfContents opts
-               then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks
-                       return [toc]
-               else return []
-  -- ... and the notes slide. We test to see if the blocks are empty,
-  -- because we don't want to make an empty slide.
-  notesSlides <- if null notesSlideBlocks
-                 then return []
-                 else do notesSlide <- local
-                           (\env -> env { envCurSlideId = noteStartNum
-                                        , envInNoteSlide = True
-                                        })
-                           (blocksToSlide $ notesSlideBlocks)
-                         return [notesSlide]
-  return $
-    Presentation $
-    metadataslides ++ tocSlides ++ bodyslides ++ notesSlides
-
---------------------------------------------------------------------
-
-copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
-copyFileToArchive arch fp = do
-  refArchive <- asks envRefArchive
-  distArchive <- asks envDistArchive
-  case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
-    Nothing -> fail $ fp ++ " missing in reference file"
-    Just e -> return $ addEntryToArchive e arch
-
-inheritedPatterns :: [Pattern]
-inheritedPatterns = map compile [ "_rels/.rels"
-                                , "docProps/app.xml"
-                                , "docProps/core.xml"
-                                , "ppt/slideLayouts/slideLayout*.xml"
-                                , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
-                                , "ppt/slideMasters/slideMaster1.xml"
-                                , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
-                                , "ppt/theme/theme1.xml"
-                                , "ppt/theme/_rels/theme1.xml.rels"
-                                , "ppt/presProps.xml"
-                                , "ppt/viewProps.xml"
-                                , "ppt/tableStyles.xml"
-                                , "ppt/media/image*"
-                                ]
-
-patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
-patternToFilePaths pat = do
-  refArchive <- asks envRefArchive
-  distArchive <- asks envDistArchive
-
-  let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
-  return $ filter (match pat) archiveFiles
-
-patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
-patternsToFilePaths pats = concat <$> mapM patternToFilePaths 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 = [ "_rels/.rels"
-                 , "docProps/app.xml"
-                 , "docProps/core.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/viewProps.xml"
-                 , "ppt/tableStyles.xml"
-                 ]
-
-
-presentationToArchive :: PandocMonad m => Presentation -> P m Archive
-presentationToArchive p@(Presentation slides) = do
-  filePaths <- patternsToFilePaths inheritedPatterns
-
-  -- make sure all required files are available:
-  let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles
-  unless (null missingFiles)
-    (throwError $
-      PandocSomeError $
-      "The following required files are missing:\n" ++
-      (unlines $ map ("  " ++) missingFiles)
-    )
-
-  newArch' <- foldM copyFileToArchive emptyArchive filePaths
-  -- presentation entry and rels. We have to do the rels first to make
-  -- sure we know the correct offset for the rIds.
-  presEntry <- presentationToPresEntry p
-  presRelsEntry <- presentationToRelsEntry p
-  slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]
-  slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]
-  -- These have to come after everything, because they need the info
-  -- built up in the state.
-  mediaEntries <- makeMediaEntries
-  contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry
-  -- fold everything into our inherited archive and return it.
-  return $ foldr addEntryToArchive newArch' $
-    slideEntries ++
-    slideRelEntries ++
-    mediaEntries ++
-    [contentTypesEntry, presEntry, presRelsEntry]
-
---------------------------------------------------
-
-combineShapes :: [Shape] -> [Shape]
-combineShapes [] = []
-combineShapes (s : []) = [s]
-combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss
-combineShapes ((TextBox []) : ss) = combineShapes ss
-combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)
-combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =
-  combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
-combineShapes (s:ss) = s : combineShapes ss
-
---------------------------------------------------
-
-getLayout :: PandocMonad m => Slide -> P m Element
-getLayout slide = do
-  let layoutpath = case slide of
-        (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"
-        (TitleSlide _)          -> "ppt/slideLayouts/slideLayout3.xml"
-        (ContentSlide _ _)      -> "ppt/slideLayouts/slideLayout2.xml"
-        (TwoColumnSlide _ _ _)    -> "ppt/slideLayouts/slideLayout4.xml"
-  distArchive <- asks envDistArchive
-  root <- case findEntryByPath layoutpath distArchive of
-        Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of
-                    Just element -> return $ element
-                    Nothing      -> throwError $
-                                    PandocSomeError $
-                                    layoutpath ++ " corrupt in reference file"
-        Nothing -> throwError $
-                   PandocSomeError $
-                   layoutpath ++ " missing in reference file"
-  return root
-
-shapeHasName :: NameSpaces -> String -> Element -> Bool
-shapeHasName ns name element
-  | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
-  , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
-  , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =
-      nm == name
-  | otherwise = False
-
-shapeHasId :: NameSpaces -> String -> Element -> Bool
-shapeHasId ns ident element
-  | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
-  , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
-  , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =
-      nm == ident
-  | otherwise = False
-
--- The content shape in slideLayout2 (Title/Content) has id=3 In
--- slideLayout4 (two column) the left column is id=3, and the right
--- column is id=4.
-getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element
-getContentShape ns spTreeElem
-  | isElem ns "p" "spTree" spTreeElem = do
-      contentType <- asks envContentType
-      let ident = case contentType of
-            NormalContent -> "3"
-            TwoColumnLeftContent -> "3"
-            TwoColumnRightContent -> "4"
-      case filterChild
-           (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e))
-           spTreeElem
-        of
-        Just e -> return e
-        Nothing -> throwError $
-                   PandocSomeError $
-                   "Could not find shape for Powerpoint content"
-getContentShape _ _ = throwError $
-                      PandocSomeError $
-                      "Attempted to find content on non shapeTree"
-
-getShapeDimensions :: NameSpaces
-                   -> Element
-                   -> Maybe ((Integer, Integer), (Integer, Integer))
-getShapeDimensions ns element
-  | isElem ns "p" "sp" element = do
-      spPr <- findChild (elemName ns "p" "spPr") element
-      xfrm <- findChild (elemName ns "a" "xfrm") spPr
-      off <- findChild (elemName ns "a" "off") xfrm
-      xS <- findAttr (QName "x" Nothing Nothing) off
-      yS <- findAttr (QName "y" Nothing Nothing) off
-      ext <- findChild (elemName ns "a" "ext") xfrm
-      cxS <- findAttr (QName "cx" Nothing Nothing) ext
-      cyS <- findAttr (QName "cy" Nothing Nothing) ext
-      (x, _) <- listToMaybe $ reads xS
-      (y, _) <- listToMaybe $ reads yS
-      (cx, _) <- listToMaybe $ reads cxS
-      (cy, _) <- listToMaybe $ reads cyS
-      return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700))
-  | otherwise = Nothing
-
-
-getMasterShapeDimensionsById :: String
-                             -> Element
-                             -> Maybe ((Integer, Integer), (Integer, Integer))
-getMasterShapeDimensionsById ident master = do
-  let ns = elemToNameSpaces master
-  cSld <- findChild (elemName ns "p" "cSld") master
-  spTree <- findChild (elemName ns "p" "spTree") cSld
-  sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree
-  getShapeDimensions ns sp
-
-getContentShapeSize :: PandocMonad m
-                    => NameSpaces
-                    -> Element
-                    -> Element
-                    -> P m ((Integer, Integer), (Integer, Integer))
-getContentShapeSize ns layout master
-  | isElem ns "p" "sldLayout" layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      sp  <- getContentShape ns spTree
-      case getShapeDimensions ns sp of
-        Just sz -> return sz
-        Nothing -> do let mbSz =
-                            findChild (elemName ns "p" "nvSpPr") sp >>=
-                            findChild (elemName ns "p" "cNvPr") >>=
-                            findAttr (QName "id" Nothing Nothing) >>=
-                            flip getMasterShapeDimensionsById master
-                      case mbSz of
-                        Just sz' -> return sz'
-                        Nothing -> throwError $
-                                   PandocSomeError $
-                                   "Couldn't find necessary content shape size"
-getContentShapeSize _ _ _ = throwError $
-                            PandocSomeError $
-                            "Attempted to find content shape size in non-layout"
-
-replaceNamedChildren :: NameSpaces
-                   -> String
-                   -> String
-                   -> [Element]
-                   -> Element
-                   -> Element
-replaceNamedChildren ns prefix name newKids element =
-  element { elContent = concat $ fun True $ elContent element }
-  where
-    fun :: Bool -> [Content] -> [[Content]]
-    fun _ [] = []
-    fun switch ((Elem e) : conts) | isElem ns prefix name e =
-                                      if switch
-                                      then (map Elem $ newKids) : fun False conts
-                                      else fun False conts
-    fun switch (cont : conts) = [cont] : fun switch conts
-
-----------------------------------------------------------------
-
-registerLink :: PandocMonad m => (URL, String) -> P m Int
-registerLink link = do
-  curSlideId <- asks envCurSlideId
-  linkReg <- gets stLinkIds
-  mediaReg <- gets stMediaIds
-  let maxLinkId = case M.lookup curSlideId linkReg of
-        Just mp -> case M.keys mp of
-          [] -> 1
-          ks -> maximum ks
-        Nothing -> 1
-      maxMediaId = case M.lookup curSlideId mediaReg of
-        Just [] -> 1
-        Just mInfos -> maximum $ map mInfoLocalId mInfos
-        Nothing -> 1
-      maxId = max maxLinkId maxMediaId
-      slideLinks = case M.lookup curSlideId linkReg of
-        Just mp -> M.insert (maxId + 1) link mp
-        Nothing -> M.singleton (maxId + 1) link
-  modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}
-  return $ maxId + 1
-
-registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
-registerMedia fp caption = do
-  curSlideId <- asks envCurSlideId
-  linkReg <- gets stLinkIds
-  mediaReg <- gets stMediaIds
-  globalIds <- gets stMediaGlobalIds
-  let maxLinkId = case M.lookup curSlideId linkReg of
-        Just mp -> case M.keys mp of
-          [] -> 1
-          ks -> maximum ks
-        Nothing -> 1
-      maxMediaId = case M.lookup curSlideId mediaReg of
-        Just [] -> 1
-        Just mInfos -> maximum $ map mInfoLocalId mInfos
-        Nothing -> 1
-      maxLocalId = max maxLinkId maxMediaId
-
-      maxGlobalId = case M.elems globalIds of
-        [] -> 0
-        ids -> maximum ids
-
-  (imgBytes, mbMt) <- P.fetchItem fp
-  let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))
-               <|>
-               case imageType imgBytes of
-                 Just Png  -> Just ".png"
-                 Just Jpeg -> Just ".jpeg"
-                 Just Gif  -> Just ".gif"
-                 Just Pdf  -> Just ".pdf"
-                 Just Eps  -> Just ".eps"
-                 Just Svg  -> Just ".svg"
-                 Nothing   -> Nothing
-
-  let newGlobalId = case M.lookup fp globalIds of
-        Just ident -> ident
-        Nothing    -> maxGlobalId + 1
-
-  let newGlobalIds = M.insert fp newGlobalId globalIds
-
-  let mediaInfo = MediaInfo { mInfoFilePath = fp
-                            , mInfoLocalId = maxLocalId + 1
-                            , mInfoGlobalId = newGlobalId
-                            , mInfoMimeType = mbMt
-                            , mInfoExt = imgExt
-                            , mInfoCaption = (not . null) caption
-                            }
-
-  let slideMediaInfos = case M.lookup curSlideId mediaReg of
-        Just minfos -> mediaInfo : minfos
-        Nothing     -> [mediaInfo]
-
-
-  modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg
-                    , stMediaGlobalIds = newGlobalIds
-                    }
-  return mediaInfo
-
-makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
-makeMediaEntry mInfo = do
-  epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
-  (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
-  let ext = case mInfoExt mInfo of
-              Just e -> e
-              Nothing -> ""
-  let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext
-  return $ toEntry fp epochtime $ BL.fromStrict imgBytes
-
-makeMediaEntries :: PandocMonad m => P m [Entry]
-makeMediaEntries = do
-  mediaInfos <- gets stMediaIds
-  let allInfos = mconcat $ M.elems mediaInfos
-  mapM makeMediaEntry 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 = do
-  refArchive <- asks envRefArchive
-  distArchive <- asks envDistArchive
-  parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"
-
--- 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 = 40
-
-createCaption :: PandocMonad m
-              => ((Integer, Integer), (Integer, Integer))
-              -> [ParaElem]
-              -> P m Element
-createCaption contentShapeDimensions paraElements = do
-  let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements
-  elements <- mapM paragraphToElement [para]
-  let ((x, y), (cx, cy)) = contentShapeDimensions
-  let txBody = mknode "p:txBody" [] $
-               [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
-  return $
-    mknode "p:sp" [] [ mknode "p:nvSpPr" []
-                       [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
-                       , mknode "p:cNvSpPr" [("txBox", "1")] ()
-                       , mknode "p:nvPr" [] ()
-                       ]
-                     , mknode "p:spPr" []
-                       [ mknode "a:xfrm" []
-                         [ mknode "a:off" [("x", show $ 12700 * x),
-                                           ("y", show $ 12700 * (y + cy - captionHeight))] ()
-                         , mknode "a:ext" [("cx", show $ 12700 * cx),
-                                           ("cy", show $ 12700 * captionHeight)] ()
-                         ]
-                       , mknode "a:prstGeom" [("prst", "rect")]
-                         [ mknode "a:avLst" [] ()
-                         ]
-                       , mknode "a:noFill" [] ()
-                       ]
-                     , txBody
-                     ]
-
-makePicElements :: PandocMonad m
-                => Element
-                -> PicProps
-                -> MediaInfo
-                -> Text.Pandoc.Definition.Attr
-                -> [ParaElem]
-                -> P m [Element]
-makePicElements layout picProps mInfo _ alt = do
-  opts <- asks envOpts
-  (pageWidth, pageHeight) <- asks envPresentationSize
-  -- hasHeader <- asks envSlideHasHeader
-  let hasCaption = mInfoCaption mInfo
-  (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
-  let (pxX, pxY) = case imageSize opts imgBytes of
-        Right sz -> sizeInPixels $ sz
-        Left _   -> sizeInPixels $ def
-  master <- getMaster
-  let ns = elemToNameSpaces layout
-  ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
-                           `catchError`
-                           (\_ -> return ((0, 0), (pageWidth, pageHeight)))
-
-  let cy = if hasCaption then cytmp - captionHeight else cytmp
-
-  let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double
-      boxRatio = fromIntegral cx / fromIntegral cy :: Double
-      (dimX, dimY) = if imgRatio > boxRatio
-                     then (fromIntegral cx, fromIntegral cx / imgRatio)
-                     else (fromIntegral cy * imgRatio, fromIntegral cy)
-
-      (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer)
-      (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2,
-                      fromIntegral y + (fromIntegral cy - dimY) / 2)
-      (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer)
-
-  let cNvPicPr = mknode "p:cNvPicPr" [] $
-                 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 cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]
-  cNvPr <- case picPropLink picProps of
-    Just link -> do idNum <- registerLink link
-                    return $ mknode "p:cNvPr" cNvPrAttr $
-                      mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()
-    Nothing   -> return $ mknode "p:cNvPr" cNvPrAttr ()
-  let nvPicPr  = mknode "p:nvPicPr" []
-                 [ cNvPr
-                 , cNvPicPr
-                 , mknode "p:nvPr" [] ()]
-  let blipFill = mknode "p:blipFill" []
-                 [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()
-                 , mknode "a:stretch" [] $
-                   mknode "a:fillRect" [] () ]
-  let xfrm =    mknode "a:xfrm" []
-                [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()
-                , mknode "a:ext" [("cx",show dimX')
-                                 ,("cy",show dimY')] () ]
-  let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
-                 mknode "a:avLst" [] ()
-  let ln =      mknode "a:ln" [("w","9525")]
-                [ mknode "a:noFill" [] ()
-                , mknode "a:headEnd" [] ()
-                , mknode "a:tailEnd" [] () ]
-  let spPr =    mknode "p:spPr" [("bwMode","auto")]
-                [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
-
-  let picShape = mknode "p:pic" []
-                 [ nvPicPr
-                 , blipFill
-                 , spPr ]
-
-  -- And now, maybe create the caption:
-  if hasCaption
-    then do cap <- createCaption ((x, y), (cx, cytmp)) alt
-            return [picShape, cap]
-    else return [picShape]
-
--- Currently hardcoded, until I figure out how to make it dynamic.
-blockQuoteSize :: Pixels
-blockQuoteSize = 20
-
-noteSize :: Pixels
-noteSize = 18
-
-paraElemToElement :: PandocMonad m => ParaElem -> P m Element
-paraElemToElement Break = return $ mknode "a:br" [] ()
-paraElemToElement (Run rpr s) = do
-  let sizeAttrs = case rPropForceSize rpr of
-                    Just n -> [("sz", (show $ n * 100))]
-                    Nothing -> []
-      attrs = sizeAttrs ++
-        if rPropCode rpr
-        then []
-        else (if rPropBold rpr then [("b", "1")] else []) ++
-             (if rPropItalics rpr then [("i", "1")] else []) ++
-             (case rStrikethrough rpr of
-                Just NoStrike     -> [("strike", "noStrike")]
-                Just SingleStrike -> [("strike", "sngStrike")]
-                Just DoubleStrike -> [("strike", "dblStrike")]
-                Nothing -> []) ++
-             (case rBaseline rpr of
-                Just n -> [("baseline", show n)]
-                Nothing -> []) ++
-             (case rCap rpr of
-                Just NoCapitals -> [("cap", "none")]
-                Just SmallCapitals -> [("cap", "small")]
-                Just AllCapitals -> [("cap", "all")]
-                Nothing -> []) ++
-             []
-  linkProps <- case rLink rpr of
-                 Just link -> do
-                   idNum <- registerLink 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.
-                   anchorMap <- gets stAnchorMap
-                   return $ case link of
-                     -- anchor with nothing in the map
-                     ('#':target, _) | Nothing <- M.lookup target anchorMap ->
-                       []
-                     --  anchor that is in the map
-                     ('#':_, _) ->
-                       let linkAttrs =
-                             [ ("r:id", "rId" ++ show idNum)
-                             , ("action", "ppaction://hlinksldjump")
-                             ]
-                       in [mknode "a:hlinkClick" linkAttrs ()]
-                     -- external
-                     _ ->
-                       let linkAttrs =
-                             [ ("r:id", "rId" ++ show idNum)
-                             ]
-                       in [mknode "a:hlinkClick" linkAttrs ()]
-                 Nothing -> return []
-  let propContents = if rPropCode rpr
-                     then [mknode "a:latin" [("typeface", "Courier")] ()]
-                     else linkProps
-  return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
-                           , mknode "a:t" [] s
-                           ]
-paraElemToElement (MathElem mathType texStr) = do
-  res <- convertMath writeOMML mathType (unTeXString texStr)
-  case res of
-    Right r -> return $ mknode "a14:m" [] $ addMathInfo r
-    Left (Str s) -> paraElemToElement (Run def s)
-    Left _       -> throwError $ PandocShouldNeverHappenError "non-string math fallback"
-
--- 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 =
-  let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))
-                       , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
-                       }
-  in add_attr mathspace 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 =
-  case findElement (QName "m" Nothing (Just "a14")) element of
-    Just _ ->
-      mknode "mc:AlternateContent"
-         [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
-         ] [ mknode "mc:Choice"
-             [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
-             , ("Requires", "a14")] [ element ]
-           ]
-    Nothing -> element
-
-paragraphToElement :: PandocMonad m => Paragraph -> P m Element
-paragraphToElement par = do
-  let
-    attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++
-            (case pPropMarginLeft (paraProps par) of
-               Just px -> [("marL", show $ 12700 * px), ("indent", "0")]
-               Nothing -> []
-            ) ++
-            (case pPropAlign (paraProps par) of
-               Just AlgnLeft -> [("algn", "l")]
-               Just AlgnRight -> [("algn", "r")]
-               Just AlgnCenter -> [("algn", "ctr")]
-               Nothing -> []
-            )
-    props = [] ++
-            (case pPropSpaceBefore $ paraProps par of
-               Just px -> [mknode "a:spcBef" [] [
-                              mknode "a:spcPts" [("val", show $ 100 * px)] ()
-                              ]
-                          ]
-               Nothing -> []
-            ) ++
-            (case pPropBullet $ paraProps par of
-               Just Bullet -> []
-               Just (AutoNumbering attrs') ->
-                 [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]
-               Nothing -> [mknode "a:buNone" [] ()]
-            )
-  paras <- mapM paraElemToElement (combineParaElems $ paraElems par)
-  return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras
-
-shapeToElement :: PandocMonad m => Element -> Shape -> P m Element
-shapeToElement layout (TextBox paras)
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      sp <- getContentShape ns spTree
-      elements <- mapM paragraphToElement paras
-      let txBody = mknode "p:txBody" [] $
-                   [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
-          emptySpPr = mknode "p:spPr" [] ()
-      return $
-        surroundWithMathAlternate $
-        replaceNamedChildren ns "p" "txBody" [txBody] $
-        replaceNamedChildren ns "p" "spPr" [emptySpPr] $
-        sp
--- GraphicFrame and Pic should never reach this.
-shapeToElement _ _ = return $ mknode "p:sp" [] ()
-
-shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
-shapeToElements layout (Pic picProps fp attr alt) = do
-  mInfo <- registerMedia fp alt
-  case mInfoExt mInfo of
-    Just _ -> do
-      makePicElements layout picProps mInfo attr alt
-    Nothing -> shapeToElements layout $ TextBox [Paragraph def alt]
-shapeToElements layout (GraphicFrame tbls cptn) =
-  graphicFrameToElements layout tbls cptn
-shapeToElements layout shp = do
-  element <- shapeToElement layout shp
-  return [element]
-
-shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]
-shapesToElements layout shps = do
- concat <$> mapM (shapeToElements layout) shps
-
-hardcodedTableMargin :: Integer
-hardcodedTableMargin = 36
-
-graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]
-graphicFrameToElements layout tbls caption = do
-  -- get the sizing
-  master <- getMaster
-  (pageWidth, pageHeight) <- asks envPresentationSize
-  let ns = elemToNameSpaces layout
-  ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
-                           `catchError`
-                           (\_ -> return ((0, 0), (pageWidth, pageHeight)))
-
-  let cy = if (not $ null caption) then cytmp - captionHeight else cytmp
-
-  elements <- mapM graphicToElement tbls
-  let graphicFrameElts =
-        mknode "p:graphicFrame" [] $
-        [ mknode "p:nvGraphicFramePr" [] $
-          [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
-          , mknode "p:cNvGraphicFramePr" [] $
-            [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
-          , mknode "p:nvPr" [] $
-            [mknode "p:ph" [("idx", "1")] ()]
-          ]
-        , mknode "p:xfrm" [] $
-          [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()
-          , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()
-          ]
-        ] ++ elements
-
-  if (not $ null caption)
-    then do capElt <- createCaption ((x, y), (cx, cytmp)) caption
-            return [graphicFrameElts, capElt]
-    else return [graphicFrameElts]
-
-graphicToElement :: PandocMonad m => Graphic -> P m Element
-graphicToElement (Tbl tblPr colWidths hdrCells rows) = do
-  let cellToOpenXML paras =
-        do elements <- mapM paragraphToElement paras
-           let elements' = if null elements
-                           then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]
-                           else elements
-           return $
-             [mknode "a:txBody" [] $
-               ([ mknode "a:bodyPr" [] ()
-                , mknode "a:lstStyle" [] ()]
-                 ++ elements')]
-  headers' <- mapM cellToOpenXML hdrCells
-  rows' <- mapM (mapM cellToOpenXML) rows
-  let borderProps = mknode "a:tcPr" [] ()
-  let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]
-  let mkcell border contents = mknode "a:tc" []
-                            $ (if null contents
-                               then emptyCell
-                               else contents) ++ [ borderProps | border ]
-  let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells
-
-  let mkgridcol w = mknode "a:gridCol"
-                       [("w", show ((12700 * w) :: Integer))] ()
-  let hasHeader = not (all null hdrCells)
-  return $ mknode "a:graphic" [] $
-    [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $
-     [mknode "a:tbl" [] $
-      [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")
-                         , ("bandRow", if tblPrBandRow tblPr then "1" else "0")
-                         ] ()
-      , mknode "a:tblGrid" [] (if all (==0) colWidths
-                               then []
-                               else map mkgridcol colWidths)
-      ]
-      ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'
-     ]
-    ]
-
-getShapeByName :: NameSpaces -> Element -> String -> Maybe Element
-getShapeByName ns spTreeElem name
-  | isElem ns "p" "spTree" spTreeElem =
-  filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem
-  | otherwise = Nothing
-
--- getShapeById :: NameSpaces -> Element -> String -> Maybe Element
--- getShapeById ns spTreeElem ident
---   | isElem ns "p" "spTree" spTreeElem =
---   filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem
---   | otherwise = Nothing
-
-nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element
-nonBodyTextToElement layout shapeName paraElements
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld
-  , Just sp <- getShapeByName ns spTree shapeName = do
-      let hdrPara = Paragraph def paraElements
-      element <- paragraphToElement hdrPara
-      let txBody = mknode "p:txBody" [] $
-                   [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
-                   [element]
-      return $ replaceNamedChildren ns "p" "txBody" [txBody] sp
-  -- XXX: TODO
-  | otherwise = return $ mknode "p:sp" [] ()
-
-contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element
-contentToElement layout hdrShape shapes
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      element <- nonBodyTextToElement layout "Title 1" hdrShape
-      let hdrShapeElements = if null hdrShape
-                             then []
-                             else [element]
-      contentElements <- local
-                         (\env -> env {envContentType = NormalContent})
-                         (shapesToElements layout shapes)
-      return $
-        replaceNamedChildren ns "p" "sp"
-        (hdrShapeElements ++ contentElements)
-        spTree
-contentToElement _ _ _ = return $ mknode "p:sp" [] ()
-
-twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
-twoColumnToElement layout hdrShape shapesL shapesR
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      element <- nonBodyTextToElement layout "Title 1" hdrShape
-      let hdrShapeElements = if null hdrShape
-                             then []
-                             else [element]
-      contentElementsL <- local
-                          (\env -> env {envContentType =TwoColumnLeftContent})
-                          (shapesToElements layout shapesL)
-      contentElementsR <- local
-                          (\env -> env {envContentType =TwoColumnRightContent})
-                          (shapesToElements layout shapesR)
-      -- let contentElementsL' = map (setIdx ns "1") contentElementsL
-      --     contentElementsR' = map (setIdx ns "2") contentElementsR
-      return $
-        replaceNamedChildren ns "p" "sp"
-        (hdrShapeElements ++ contentElementsL ++ contentElementsR)
-        spTree
-twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()
-
-
-titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
-titleToElement layout titleElems
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      element <- nonBodyTextToElement layout "Title 1" titleElems
-      let titleShapeElements = if null titleElems
-                               then []
-                               else [element]
-      return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree
-titleToElement _ _ = return $ mknode "p:sp" [] ()
-
-metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element
-metadataToElement layout titleElems subtitleElems authorsElems dateElems
-  | ns <- elemToNameSpaces layout
-  , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      titleShapeElements <- if null titleElems
-                            then return []
-                            else sequence [nonBodyTextToElement layout "Title 1" titleElems]
-      let combinedAuthorElems = intercalate [Break] authorsElems
-          subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]
-      subtitleShapeElements <- if null subtitleAndAuthorElems
-                               then return []
-                               else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]
-      dateShapeElements <- if null dateElems
-                           then return []
-                           else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]
-      return $ replaceNamedChildren ns "p" "sp"
-        (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)
-        spTree
-metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()
-
-slideToElement :: PandocMonad m => Slide -> P m Element
-slideToElement s@(ContentSlide hdrElems shapes) = do
-  layout <- getLayout s
-  spTree <- local (\env -> if null hdrElems
-                           then env
-                           else env{envSlideHasHeader=True}) $
-            contentToElement layout hdrElems shapes
-  return $ 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")
-    ] [mknode "p:cSld" [] [spTree]]
-slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do
-  layout <- getLayout s
-  spTree <- local (\env -> if null hdrElems
-                           then env
-                           else env{envSlideHasHeader=True}) $
-            twoColumnToElement layout hdrElems shapesL shapesR
-  return $ 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")
-    ] [mknode "p:cSld" [] [spTree]]
-slideToElement s@(TitleSlide hdrElems) = do
-  layout <- getLayout s
-  spTree <- titleToElement layout hdrElems
-  return $ 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")
-    ] [mknode "p:cSld" [] [spTree]]
-slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do
-  layout <- getLayout s
-  spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems
-  return $ 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")
-    ] [mknode "p:cSld" [] [spTree]]
-
------------------------------------------------------------------------
-
-slideToFilePath :: Slide -> Int -> FilePath
-slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"
-
-slideToSlideId :: Monad m => Slide -> Int -> P m String
-slideToSlideId _ idNum = do
-  n <- asks envSlideIdOffset
-  return $ "rId" ++ (show $ idNum + n)
-
-
-data Relationship = Relationship { relId :: Int
-                                 , relType :: MimeType
-                                 , relTarget :: FilePath
-                                 } deriving (Show, Eq)
-
-elementToRel :: Element -> Maybe Relationship
-elementToRel element
-  | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =
-      do rId <- findAttr (QName "Id" Nothing Nothing) element
-         numStr <- stripPrefix "rId" rId
-         num <- case reads numStr :: [(Int, String)] of
-           (n, _) : _ -> Just n
-           []         -> Nothing
-         type' <- findAttr (QName "Type" Nothing Nothing) element
-         target <- findAttr (QName "Target" Nothing Nothing) element
-         return $ Relationship num type' target
-  | otherwise = Nothing
-
-slideToPresRel :: Monad m => Slide -> Int -> P m Relationship
-slideToPresRel slide idNum = do
-  n <- asks envSlideIdOffset
-  let rId = idNum + n
-      fp = "slides/" ++ slideToFilePath slide idNum
-  return $ Relationship { relId = rId
-                        , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
-                        , relTarget = fp
-                        }
-
-getRels :: PandocMonad m => P m [Relationship]
-getRels = do
-  refArchive <- asks envRefArchive
-  distArchive <- asks envDistArchive
-  relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"
-  let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
-  let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem
-  return $ mapMaybe elementToRel relElems
-
-presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
-presentationToRels (Presentation slides) = do
-  mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]
-  rels <- getRels
-  let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
-  -- We want to make room for the slides in the id space. The slides
-  -- will start at Id2 (since Id1 is for the slide master). There are
-  -- two slides in the data file, but that might change in the future,
-  -- so we will do this:
-  --
-  -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.
-  -- 2. We add the difference between this and the number of slides to
-  -- all relWithoutSlide rels (unless they're 1)
-
-  let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of
-        [] -> 0                 -- doesn't matter in this case, since
-                                -- there will be nothing to map the
-                                -- function over
-        l  -> minimum l
-
-      modifyRelNum :: Int -> Int
-      modifyRelNum 1 = 1
-      modifyRelNum n = n - minRelNotOne + 2 + length slides
-
-      relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides
-
-  return $ mySlideRels ++ relsWithoutSlides'
-
-relToElement :: Relationship -> Element
-relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))
-                                         , ("Type", relType rel)
-                                         , ("Target", relTarget rel) ] ()
-
-relsToElement :: [Relationship] -> Element
-relsToElement rels = mknode "Relationships"
-                     [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
-                     (map relToElement rels)
-
-presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry
-presentationToRelsEntry pres = do
-  rels <- presentationToRels pres
-  elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels
-
-elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
-elemToEntry fp element = do
-  epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
-  return $ toEntry fp epochtime $ renderXml element
-
-slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry
-slideToEntry slide idNum = do
-  local (\env -> env{envCurSlideId = idNum}) $ do
-    element <- slideToElement slide
-    elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element
-
-slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
-slideToSlideRelEntry slide idNum = do
-  element <- slideToSlideRelElement slide idNum
-  elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
-
-linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element)
-linkRelElement idNum (url, _) = do
-  anchorMap <- gets stAnchorMap
-  case url of
-    -- if it's an anchor in the map, we use the slide number for an
-    -- internal link.
-    '#' : anchor | Just num <- M.lookup anchor anchorMap ->
-      return $ Just $
-      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
-                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
-                            , ("Target", "slide" ++ show num ++ ".xml")
-                            ] ()
-    -- if it's an anchor not in the map, we return nothing.
-    '#' : _ -> return Nothing
-    -- Anything else we treat as an external link
-    _ ->
-      return $ Just $
-      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
-                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
-                        , ("Target", url)
-                        , ("TargetMode", "External")
-                        ] ()
-
-linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]
-linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
-
-mediaRelElement :: MediaInfo -> Element
-mediaRelElement mInfo =
-  let ext = case mInfoExt mInfo of
-              Just e -> e
-              Nothing -> ""
-  in
-    mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))
-                          , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
-                          , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
-                          ] ()
-
-slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element
-slideToSlideRelElement slide idNum = do
-  let target =  case slide of
-        (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"
-        (TitleSlide _)        -> "../slideLayouts/slideLayout3.xml"
-        (ContentSlide _ _)    -> "../slideLayouts/slideLayout2.xml"
-        (TwoColumnSlide _ _ _)    -> "../slideLayouts/slideLayout4.xml"
-
-  linkIds <- gets stLinkIds
-  mediaIds <- gets stMediaIds
-
-  linkRels <- case M.lookup idNum linkIds of
-                Just mp -> linkRelElements mp
-                Nothing -> return []
-  let mediaRels = case M.lookup idNum mediaIds of
-                   Just mInfos -> map mediaRelElement mInfos
-                   Nothing -> []
-
-  return $
-    mknode "Relationships"
-    [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
-    ([mknode "Relationship" [ ("Id", "rId1")
-                           , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
-                           , ("Target", target)] ()
-    ] ++ linkRels ++ mediaRels)
-
-slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element
-slideToSldIdElement slide idNum = do
-  let id' = show $ idNum + 255
-  rId <- slideToSlideId slide idNum
-  return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
-
-presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
-presentationToSldIdLst (Presentation slides) = do
-  ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
-  return $ mknode "p:sldIdLst" [] ids
-
-presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
-presentationToPresentationElement pres = do
-  refArchive <- asks envRefArchive
-  distArchive <- asks envDistArchive
-  element <- parseXml refArchive distArchive "ppt/presentation.xml"
-  sldIdLst <- presentationToSldIdLst pres
-
-  let modifySldIdLst :: Content -> Content
-      modifySldIdLst (Elem e) = case elName e of
-        (QName "sldIdLst" _ _) -> Elem sldIdLst
-        _                      -> Elem e
-      modifySldIdLst ct = ct
-
-      newContent = map modifySldIdLst $ elContent element
-
-  return $ element{elContent = newContent}
-
-presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry
-presentationToPresEntry pres = presentationToPresentationElement pres >>=
-  elemToEntry "ppt/presentation.xml"
-
-
-
-
-defaultContentTypeToElem :: DefaultContentType -> Element
-defaultContentTypeToElem dct =
-  mknode "Default"
-  [("Extension", defContentTypesExt dct),
-    ("ContentType", defContentTypesType dct)]
-  ()
-
-overrideContentTypeToElem :: OverrideContentType -> Element
-overrideContentTypeToElem oct =
-  mknode "Override"
-  [("PartName", overrideContentTypesPart oct),
-    ("ContentType", overrideContentTypesType oct)]
-  ()
-
-contentTypesToElement :: ContentTypes -> Element
-contentTypesToElement ct =
-  let ns = "http://schemas.openxmlformats.org/package/2006/content-types"
-  in
-    mknode "Types" [("xmlns", ns)] $
-    (map defaultContentTypeToElem $ contentTypesDefaults ct) ++
-    (map overrideContentTypeToElem $ contentTypesOverrides ct)
-
-data DefaultContentType = DefaultContentType
-                           { defContentTypesExt :: String
-                           , defContentTypesType:: MimeType
-                           }
-                         deriving (Show, Eq)
-
-data OverrideContentType = OverrideContentType
-                           { overrideContentTypesPart :: FilePath
-                           , overrideContentTypesType :: MimeType
-                           }
-                          deriving (Show, Eq)
-
-data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]
-                                 , contentTypesOverrides :: [OverrideContentType]
-                                 }
-                    deriving (Show, Eq)
-
-contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
-contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct
-
-pathToOverride :: FilePath -> Maybe OverrideContentType
-pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
-
-mediaFileContentType :: FilePath -> Maybe DefaultContentType
-mediaFileContentType fp = case takeExtension fp of
-  '.' : ext -> Just $
-               DefaultContentType { defContentTypesExt = ext
-                                  , defContentTypesType =
-                                      case getMimeType fp of
-                                        Just mt -> mt
-                                        Nothing -> "application/octet-stream"
-                                  }
-  _ -> Nothing
-
-mediaContentType :: MediaInfo -> Maybe DefaultContentType
-mediaContentType mInfo
-  | Just ('.' : ext) <- mInfoExt mInfo =
-      Just $ DefaultContentType { defContentTypesExt = ext
-                                , defContentTypesType =
-                                    case mInfoMimeType mInfo of
-                                      Just mt -> mt
-                                      Nothing -> "application/octet-stream"
-                                }
-  | otherwise = Nothing
-
-presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
-presentationToContentTypes (Presentation slides) = do
-  mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
-  filePaths <- patternsToFilePaths inheritedPatterns
-  let mediaFps = filter (match (compile "ppt/media/image*")) filePaths
-  let defaults = [ DefaultContentType "xml" "application/xml"
-                 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
-                 ]
-      mediaDefaults = nub $
-                      (mapMaybe mediaContentType $ mediaInfos) ++
-                      (mapMaybe mediaFileContentType $ mediaFps)
-
-      inheritedOverrides = mapMaybe pathToOverride filePaths
-      presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
-      slideOverrides =
-        mapMaybe
-        (\(s, n) ->
-           pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)
-        (zip slides [1..])
-      -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]
-  return $ ContentTypes
-    (defaults ++ mediaDefaults)
-    (inheritedOverrides ++ presOverride ++ slideOverrides)
-
-presML :: String
-presML = "application/vnd.openxmlformats-officedocument.presentationml"
-
-noPresML :: String
-noPresML = "application/vnd.openxmlformats-officedocument"
-
-getContentType :: FilePath -> Maybe MimeType
-getContentType fp
-  | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"
-  | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"
-  | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"
-  | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"
-  | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"
-  | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"
-  | "ppt" : "slideMasters" : f : [] <- splitDirectories fp
-  , (_, ".xml") <- splitExtension f =
-      Just $ presML ++ ".slideMaster+xml"
-  | "ppt" : "slides" : f : [] <- splitDirectories fp
-  , (_, ".xml") <- splitExtension f =
-      Just $ presML ++ ".slide+xml"
-  | "ppt" : "notesMasters"  : f : [] <- splitDirectories fp
-  , (_, ".xml") <- splitExtension f =
-      Just $ presML ++ ".notesMaster+xml"
-  | "ppt" : "notesSlides"  : f : [] <- splitDirectories fp
-  , (_, ".xml") <- splitExtension f =
-      Just $ presML ++ ".notesSlide+xml"
-  | "ppt" : "theme" : f : [] <- splitDirectories fp
-  , (_, ".xml") <- splitExtension f =
-      Just $ noPresML ++ ".theme+xml"
-  | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=
-      Just $ presML ++ ".slideLayout+xml"
-  | otherwise = Nothing
-
--------------------------------------------------------
-
-combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]
-combineParaElems' mbPElem [] = maybeToList mbPElem
-combineParaElems' Nothing (pElem : pElems) =
-  combineParaElems' (Just pElem) pElems
-combineParaElems' (Just pElem') (pElem : pElems)
-  | Run rPr' s' <- pElem'
-  , Run rPr s <- pElem
-  , rPr == rPr' =
-    combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems
-  | otherwise =
-    pElem' : combineParaElems' (Just pElem) pElems
-
-combineParaElems :: [ParaElem] -> [ParaElem]
-combineParaElems = combineParaElems' Nothing
+  pres <- documentToPresentation opts (Pandoc meta blks')
+  archv <- presentationToArchive opts pres
+  return $ fromArchive archv
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
new file mode 100644
index 000000000..f3df62690
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -0,0 +1,1431 @@
+{-# LANGUAGE PatternGuards #-}
+
+{-
+Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.Writers.Powerpoint.Output
+   Copyright   : Copyright (C) 2017-2018 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)
+import Data.Default
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
+import Text.XML.Light
+import Text.Pandoc.Definition
+import qualified Text.Pandoc.UTF8 as UTF8
+import Text.Pandoc.Class (PandocMonad)
+import Text.Pandoc.Error (PandocError(..))
+import qualified Text.Pandoc.Class as P
+import Text.Pandoc.Options
+import Text.Pandoc.MIME
+import qualified Data.ByteString.Lazy as BL
+import Text.Pandoc.Writers.OOXML
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, listToMaybe, catMaybes)
+import Text.Pandoc.ImageSize
+import Control.Applicative ((<|>))
+import System.FilePath.Glob
+import Text.TeXMath
+import Text.Pandoc.Writers.Math (convertMath)
+import Text.Pandoc.Writers.Powerpoint.Presentation
+
+-- 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 refArchive distArchive =
+  let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
+      mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles
+
+      go :: FilePath -> Maybe (FilePath, Int)
+      go fp = do
+        s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp
+        (n, _) <- listToMaybe $ reads s
+        return (fp, n)
+  in
+    M.fromList $ mapMaybe go mediaPaths
+
+getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)
+getPresentationSize refArchive distArchive = do
+  entry <- findEntryByPath "ppt/presentation.xml" refArchive  `mplus`
+           findEntryByPath "ppt/presentation.xml" distArchive
+  presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry
+  let ns = elemToNameSpaces presElement
+  sldSize <- findChild (elemName ns "p" "sldSz") presElement
+  cxS <- findAttr (QName "cx" Nothing Nothing) sldSize
+  cyS <- findAttr (QName "cy" Nothing Nothing) sldSize
+  (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)
+  (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)
+  return (cx `div` 12700, cy `div` 12700)
+
+data WriterEnv = WriterEnv { envRefArchive :: Archive
+                           , envDistArchive :: Archive
+                           , envUTCTime :: UTCTime
+                           , envOpts :: WriterOptions
+                           , envPresentationSize :: (Integer, Integer)
+                           , envSlideHasHeader :: Bool
+                           , envInList :: Bool
+                           , envInNoteSlide :: Bool
+                           , envCurSlideId :: Int
+                           -- the difference between the number at
+                           -- the end of the slide file name and
+                           -- the rId number
+                           , envSlideIdOffset :: Int
+                           , envContentType :: ContentType
+                           }
+                 deriving (Show)
+
+instance Default WriterEnv where
+  def = WriterEnv { envRefArchive = emptyArchive
+                  , envDistArchive = emptyArchive
+                  , envUTCTime = posixSecondsToUTCTime 0
+                  , envOpts = def
+                  , envPresentationSize = (720, 540)
+                  , envSlideHasHeader = False
+                  , envInList = False
+                  , envInNoteSlide = False
+                  , envCurSlideId = 1
+                  , envSlideIdOffset = 1
+                  , envContentType = NormalContent
+                  }
+
+data ContentType = NormalContent
+                 | TwoColumnLeftContent
+                 | TwoColumnRightContent
+                 deriving (Show, Eq)
+
+data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
+                           , mInfoLocalId  :: Int
+                           , mInfoGlobalId :: Int
+                           , mInfoMimeType :: Maybe MimeType
+                           , mInfoExt      :: Maybe String
+                           , mInfoCaption  :: Bool
+                           } deriving (Show, Eq)
+
+data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String))
+                               -- (FP, Local ID, Global ID, Maybe Mime)
+                               , stMediaIds :: M.Map Int [MediaInfo]
+                               , stMediaGlobalIds :: M.Map FilePath Int
+                               , stNoteIds :: M.Map Int [Block]
+                               -- associate anchors with slide id
+                               , stAnchorMap :: M.Map String Int
+                               -- media inherited from the template.
+                               , stTemplateMedia :: [FilePath]
+                               } deriving (Show, Eq)
+
+instance Default WriterState where
+  def = WriterState { stLinkIds = mempty
+                    , stMediaIds = mempty
+                    , stMediaGlobalIds = mempty
+                    , stNoteIds = mempty
+                    , stAnchorMap= mempty
+                    , stTemplateMedia = []
+                    }
+
+type P m = ReaderT WriterEnv (StateT WriterState m)
+
+runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
+runP env st p = evalStateT (runReaderT p env) st
+
+--------------------------------------------------------------------
+
+copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
+copyFileToArchive arch fp = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
+    Nothing -> fail $ fp ++ " missing in reference file"
+    Just e -> return $ addEntryToArchive e arch
+
+inheritedPatterns :: [Pattern]
+inheritedPatterns = map compile [ "_rels/.rels"
+                                , "docProps/app.xml"
+                                , "docProps/core.xml"
+                                , "ppt/slideLayouts/slideLayout*.xml"
+                                , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
+                                , "ppt/slideMasters/slideMaster1.xml"
+                                , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
+                                , "ppt/theme/theme1.xml"
+                                , "ppt/theme/_rels/theme1.xml.rels"
+                                , "ppt/presProps.xml"
+                                , "ppt/viewProps.xml"
+                                , "ppt/tableStyles.xml"
+                                , "ppt/media/image*"
+                                ]
+
+patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
+patternToFilePaths pat = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+
+  let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
+  return $ filter (match pat) archiveFiles
+
+patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
+patternsToFilePaths pats = concat <$> mapM patternToFilePaths 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 = [ "_rels/.rels"
+                 , "docProps/app.xml"
+                 , "docProps/core.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/viewProps.xml"
+                 , "ppt/tableStyles.xml"
+                 ]
+
+
+presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive
+presentationToArchiveP p@(Presentation slides) = do
+  filePaths <- patternsToFilePaths inheritedPatterns
+
+  -- make sure all required files are available:
+  let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles
+  unless (null missingFiles)
+    (throwError $
+      PandocSomeError $
+      "The following required files are missing:\n" ++
+      (unlines $ map ("  " ++) missingFiles)
+    )
+
+  newArch' <- foldM copyFileToArchive emptyArchive filePaths
+  -- presentation entry and rels. We have to do the rels first to make
+  -- sure we know the correct offset for the rIds.
+  presEntry <- presentationToPresEntry p
+  presRelsEntry <- presentationToRelsEntry p
+  slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]
+  slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]
+  -- These have to come after everything, because they need the info
+  -- built up in the state.
+  mediaEntries <- makeMediaEntries
+  contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry
+  -- fold everything into our inherited archive and return it.
+  return $ foldr addEntryToArchive newArch' $
+    slideEntries ++
+    slideRelEntries ++
+    mediaEntries ++
+    [contentTypesEntry, presEntry, presRelsEntry]
+
+presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive
+presentationToArchive opts pres = do
+  distArchive <- (toArchive . BL.fromStrict) <$>
+                      P.readDefaultDataFile "reference.pptx"
+  refArchive <- case writerReferenceDoc opts of
+                     Just f  -> toArchive <$> P.readFileLazy f
+                     Nothing -> (toArchive . BL.fromStrict) <$>
+                        P.readDataFile "reference.pptx"
+
+  utctime <- P.getCurrentTime
+
+  presSize <- case getPresentationSize refArchive distArchive of
+                Just sz -> return sz
+                Nothing -> throwError $
+                           PandocSomeError $
+                           "Could not determine presentation size"
+
+  let env = def { envRefArchive = refArchive
+                , envDistArchive = distArchive
+                , envUTCTime = utctime
+                , envOpts = opts
+                , envPresentationSize = presSize
+                }
+
+  let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
+               }
+
+  runP env st $ presentationToArchiveP pres
+
+
+
+--------------------------------------------------
+
+--------------------------------------------------
+
+getLayout :: PandocMonad m => Slide -> P m Element
+getLayout slide = do
+  let layoutpath = case slide of
+        (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"
+        (TitleSlide _)          -> "ppt/slideLayouts/slideLayout3.xml"
+        (ContentSlide _ _)      -> "ppt/slideLayouts/slideLayout2.xml"
+        (TwoColumnSlide _ _ _)    -> "ppt/slideLayouts/slideLayout4.xml"
+  distArchive <- asks envDistArchive
+  root <- case findEntryByPath layoutpath distArchive of
+        Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of
+                    Just element -> return $ element
+                    Nothing      -> throwError $
+                                    PandocSomeError $
+                                    layoutpath ++ " corrupt in reference file"
+        Nothing -> throwError $
+                   PandocSomeError $
+                   layoutpath ++ " missing in reference file"
+  return root
+
+shapeHasName :: NameSpaces -> String -> Element -> Bool
+shapeHasName ns name element
+  | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
+  , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
+  , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =
+      nm == name
+  | otherwise = False
+
+shapeHasId :: NameSpaces -> String -> Element -> Bool
+shapeHasId ns ident element
+  | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
+  , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
+  , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =
+      nm == ident
+  | otherwise = False
+
+-- The content shape in slideLayout2 (Title/Content) has id=3 In
+-- slideLayout4 (two column) the left column is id=3, and the right
+-- column is id=4.
+getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element
+getContentShape ns spTreeElem
+  | isElem ns "p" "spTree" spTreeElem = do
+      contentType <- asks envContentType
+      let ident = case contentType of
+            NormalContent -> "3"
+            TwoColumnLeftContent -> "3"
+            TwoColumnRightContent -> "4"
+      case filterChild
+           (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e))
+           spTreeElem
+        of
+        Just e -> return e
+        Nothing -> throwError $
+                   PandocSomeError $
+                   "Could not find shape for Powerpoint content"
+getContentShape _ _ = throwError $
+                      PandocSomeError $
+                      "Attempted to find content on non shapeTree"
+
+getShapeDimensions :: NameSpaces
+                   -> Element
+                   -> Maybe ((Integer, Integer), (Integer, Integer))
+getShapeDimensions ns element
+  | isElem ns "p" "sp" element = do
+      spPr <- findChild (elemName ns "p" "spPr") element
+      xfrm <- findChild (elemName ns "a" "xfrm") spPr
+      off <- findChild (elemName ns "a" "off") xfrm
+      xS <- findAttr (QName "x" Nothing Nothing) off
+      yS <- findAttr (QName "y" Nothing Nothing) off
+      ext <- findChild (elemName ns "a" "ext") xfrm
+      cxS <- findAttr (QName "cx" Nothing Nothing) ext
+      cyS <- findAttr (QName "cy" Nothing Nothing) ext
+      (x, _) <- listToMaybe $ reads xS
+      (y, _) <- listToMaybe $ reads yS
+      (cx, _) <- listToMaybe $ reads cxS
+      (cy, _) <- listToMaybe $ reads cyS
+      return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700))
+  | otherwise = Nothing
+
+
+getMasterShapeDimensionsById :: String
+                             -> Element
+                             -> Maybe ((Integer, Integer), (Integer, Integer))
+getMasterShapeDimensionsById ident master = do
+  let ns = elemToNameSpaces master
+  cSld <- findChild (elemName ns "p" "cSld") master
+  spTree <- findChild (elemName ns "p" "spTree") cSld
+  sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree
+  getShapeDimensions ns sp
+
+getContentShapeSize :: PandocMonad m
+                    => NameSpaces
+                    -> Element
+                    -> Element
+                    -> P m ((Integer, Integer), (Integer, Integer))
+getContentShapeSize ns layout master
+  | isElem ns "p" "sldLayout" layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      sp  <- getContentShape ns spTree
+      case getShapeDimensions ns sp of
+        Just sz -> return sz
+        Nothing -> do let mbSz =
+                            findChild (elemName ns "p" "nvSpPr") sp >>=
+                            findChild (elemName ns "p" "cNvPr") >>=
+                            findAttr (QName "id" Nothing Nothing) >>=
+                            flip getMasterShapeDimensionsById master
+                      case mbSz of
+                        Just sz' -> return sz'
+                        Nothing -> throwError $
+                                   PandocSomeError $
+                                   "Couldn't find necessary content shape size"
+getContentShapeSize _ _ _ = throwError $
+                            PandocSomeError $
+                            "Attempted to find content shape size in non-layout"
+
+replaceNamedChildren :: NameSpaces
+                   -> String
+                   -> String
+                   -> [Element]
+                   -> Element
+                   -> Element
+replaceNamedChildren ns prefix name newKids element =
+  element { elContent = concat $ fun True $ elContent element }
+  where
+    fun :: Bool -> [Content] -> [[Content]]
+    fun _ [] = []
+    fun switch ((Elem e) : conts) | isElem ns prefix name e =
+                                      if switch
+                                      then (map Elem $ newKids) : fun False conts
+                                      else fun False conts
+    fun switch (cont : conts) = [cont] : fun switch conts
+
+----------------------------------------------------------------
+
+registerLink :: PandocMonad m => (URL, String) -> P m Int
+registerLink link = do
+  curSlideId <- asks envCurSlideId
+  linkReg <- gets stLinkIds
+  mediaReg <- gets stMediaIds
+  let maxLinkId = case M.lookup curSlideId linkReg of
+        Just mp -> case M.keys mp of
+          [] -> 1
+          ks -> maximum ks
+        Nothing -> 1
+      maxMediaId = case M.lookup curSlideId mediaReg of
+        Just [] -> 1
+        Just mInfos -> maximum $ map mInfoLocalId mInfos
+        Nothing -> 1
+      maxId = max maxLinkId maxMediaId
+      slideLinks = case M.lookup curSlideId linkReg of
+        Just mp -> M.insert (maxId + 1) link mp
+        Nothing -> M.singleton (maxId + 1) link
+  modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}
+  return $ maxId + 1
+
+registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
+registerMedia fp caption = do
+  curSlideId <- asks envCurSlideId
+  linkReg <- gets stLinkIds
+  mediaReg <- gets stMediaIds
+  globalIds <- gets stMediaGlobalIds
+  let maxLinkId = case M.lookup curSlideId linkReg of
+        Just mp -> case M.keys mp of
+          [] -> 1
+          ks -> maximum ks
+        Nothing -> 1
+      maxMediaId = case M.lookup curSlideId mediaReg of
+        Just [] -> 1
+        Just mInfos -> maximum $ map mInfoLocalId mInfos
+        Nothing -> 1
+      maxLocalId = max maxLinkId maxMediaId
+
+      maxGlobalId = case M.elems globalIds of
+        [] -> 0
+        ids -> maximum ids
+
+  (imgBytes, mbMt) <- P.fetchItem fp
+  let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))
+               <|>
+               case imageType imgBytes of
+                 Just Png  -> Just ".png"
+                 Just Jpeg -> Just ".jpeg"
+                 Just Gif  -> Just ".gif"
+                 Just Pdf  -> Just ".pdf"
+                 Just Eps  -> Just ".eps"
+                 Just Svg  -> Just ".svg"
+                 Nothing   -> Nothing
+
+  let newGlobalId = case M.lookup fp globalIds of
+        Just ident -> ident
+        Nothing    -> maxGlobalId + 1
+
+  let newGlobalIds = M.insert fp newGlobalId globalIds
+
+  let mediaInfo = MediaInfo { mInfoFilePath = fp
+                            , mInfoLocalId = maxLocalId + 1
+                            , mInfoGlobalId = newGlobalId
+                            , mInfoMimeType = mbMt
+                            , mInfoExt = imgExt
+                            , mInfoCaption = (not . null) caption
+                            }
+
+  let slideMediaInfos = case M.lookup curSlideId mediaReg of
+        Just minfos -> mediaInfo : minfos
+        Nothing     -> [mediaInfo]
+
+
+  modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg
+                    , stMediaGlobalIds = newGlobalIds
+                    }
+  return mediaInfo
+
+makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
+makeMediaEntry mInfo = do
+  epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
+  (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
+  let ext = case mInfoExt mInfo of
+              Just e -> e
+              Nothing -> ""
+  let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext
+  return $ toEntry fp epochtime $ BL.fromStrict imgBytes
+
+makeMediaEntries :: PandocMonad m => P m [Entry]
+makeMediaEntries = do
+  mediaInfos <- gets stMediaIds
+  let allInfos = mconcat $ M.elems mediaInfos
+  mapM makeMediaEntry 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 = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"
+
+-- 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 = 40
+
+createCaption :: PandocMonad m
+              => ((Integer, Integer), (Integer, Integer))
+              -> [ParaElem]
+              -> P m Element
+createCaption contentShapeDimensions paraElements = do
+  let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements
+  elements <- mapM paragraphToElement [para]
+  let ((x, y), (cx, cy)) = contentShapeDimensions
+  let txBody = mknode "p:txBody" [] $
+               [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
+  return $
+    mknode "p:sp" [] [ mknode "p:nvSpPr" []
+                       [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
+                       , mknode "p:cNvSpPr" [("txBox", "1")] ()
+                       , mknode "p:nvPr" [] ()
+                       ]
+                     , mknode "p:spPr" []
+                       [ mknode "a:xfrm" []
+                         [ mknode "a:off" [("x", show $ 12700 * x),
+                                           ("y", show $ 12700 * (y + cy - captionHeight))] ()
+                         , mknode "a:ext" [("cx", show $ 12700 * cx),
+                                           ("cy", show $ 12700 * captionHeight)] ()
+                         ]
+                       , mknode "a:prstGeom" [("prst", "rect")]
+                         [ mknode "a:avLst" [] ()
+                         ]
+                       , mknode "a:noFill" [] ()
+                       ]
+                     , txBody
+                     ]
+
+makePicElements :: PandocMonad m
+                => Element
+                -> PicProps
+                -> MediaInfo
+                -> Text.Pandoc.Definition.Attr
+                -> [ParaElem]
+                -> P m [Element]
+makePicElements layout picProps mInfo _ alt = do
+  opts <- asks envOpts
+  (pageWidth, pageHeight) <- asks envPresentationSize
+  -- hasHeader <- asks envSlideHasHeader
+  let hasCaption = mInfoCaption mInfo
+  (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
+  let (pxX, pxY) = case imageSize opts imgBytes of
+        Right sz -> sizeInPixels $ sz
+        Left _   -> sizeInPixels $ def
+  master <- getMaster
+  let ns = elemToNameSpaces layout
+  ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
+                           `catchError`
+                           (\_ -> return ((0, 0), (pageWidth, pageHeight)))
+
+  let cy = if hasCaption then cytmp - captionHeight else cytmp
+
+  let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double
+      boxRatio = fromIntegral cx / fromIntegral cy :: Double
+      (dimX, dimY) = if imgRatio > boxRatio
+                     then (fromIntegral cx, fromIntegral cx / imgRatio)
+                     else (fromIntegral cy * imgRatio, fromIntegral cy)
+
+      (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer)
+      (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2,
+                      fromIntegral y + (fromIntegral cy - dimY) / 2)
+      (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer)
+
+  let cNvPicPr = mknode "p:cNvPicPr" [] $
+                 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 cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]
+  cNvPr <- case picPropLink picProps of
+    Just link -> do idNum <- registerLink link
+                    return $ mknode "p:cNvPr" cNvPrAttr $
+                      mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()
+    Nothing   -> return $ mknode "p:cNvPr" cNvPrAttr ()
+  let nvPicPr  = mknode "p:nvPicPr" []
+                 [ cNvPr
+                 , cNvPicPr
+                 , mknode "p:nvPr" [] ()]
+  let blipFill = mknode "p:blipFill" []
+                 [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()
+                 , mknode "a:stretch" [] $
+                   mknode "a:fillRect" [] () ]
+  let xfrm =    mknode "a:xfrm" []
+                [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()
+                , mknode "a:ext" [("cx",show dimX')
+                                 ,("cy",show dimY')] () ]
+  let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
+                 mknode "a:avLst" [] ()
+  let ln =      mknode "a:ln" [("w","9525")]
+                [ mknode "a:noFill" [] ()
+                , mknode "a:headEnd" [] ()
+                , mknode "a:tailEnd" [] () ]
+  let spPr =    mknode "p:spPr" [("bwMode","auto")]
+                [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
+
+  let picShape = mknode "p:pic" []
+                 [ nvPicPr
+                 , blipFill
+                 , spPr ]
+
+  -- And now, maybe create the caption:
+  if hasCaption
+    then do cap <- createCaption ((x, y), (cx, cytmp)) alt
+            return [picShape, cap]
+    else return [picShape]
+
+
+paraElemToElement :: PandocMonad m => ParaElem -> P m Element
+paraElemToElement Break = return $ mknode "a:br" [] ()
+paraElemToElement (Run rpr s) = do
+  let sizeAttrs = case rPropForceSize rpr of
+                    Just n -> [("sz", (show $ n * 100))]
+                    Nothing -> []
+      attrs = sizeAttrs ++
+        if rPropCode rpr
+        then []
+        else (if rPropBold rpr then [("b", "1")] else []) ++
+             (if rPropItalics rpr then [("i", "1")] else []) ++
+             (case rStrikethrough rpr of
+                Just NoStrike     -> [("strike", "noStrike")]
+                Just SingleStrike -> [("strike", "sngStrike")]
+                Just DoubleStrike -> [("strike", "dblStrike")]
+                Nothing -> []) ++
+             (case rBaseline rpr of
+                Just n -> [("baseline", show n)]
+                Nothing -> []) ++
+             (case rCap rpr of
+                Just NoCapitals -> [("cap", "none")]
+                Just SmallCapitals -> [("cap", "small")]
+                Just AllCapitals -> [("cap", "all")]
+                Nothing -> []) ++
+             []
+  linkProps <- case rLink rpr of
+                 Just link -> do
+                   idNum <- registerLink 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.
+                   anchorMap <- gets stAnchorMap
+                   return $ case link of
+                     -- anchor with nothing in the map
+                     ('#':target, _) | Nothing <- M.lookup target anchorMap ->
+                       []
+                     --  anchor that is in the map
+                     ('#':_, _) ->
+                       let linkAttrs =
+                             [ ("r:id", "rId" ++ show idNum)
+                             , ("action", "ppaction://hlinksldjump")
+                             ]
+                       in [mknode "a:hlinkClick" linkAttrs ()]
+                     -- external
+                     _ ->
+                       let linkAttrs =
+                             [ ("r:id", "rId" ++ show idNum)
+                             ]
+                       in [mknode "a:hlinkClick" linkAttrs ()]
+                 Nothing -> return []
+  let propContents = if rPropCode rpr
+                     then [mknode "a:latin" [("typeface", "Courier")] ()]
+                     else linkProps
+  return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
+                           , mknode "a:t" [] s
+                           ]
+paraElemToElement (MathElem mathType texStr) = do
+  res <- convertMath writeOMML mathType (unTeXString texStr)
+  case res of
+    Right r -> return $ mknode "a14:m" [] $ addMathInfo r
+    Left (Str s) -> paraElemToElement (Run def s)
+    Left _       -> throwError $ PandocShouldNeverHappenError "non-string math fallback"
+
+-- 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 =
+  let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))
+                       , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
+                       }
+  in add_attr mathspace 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 =
+  case findElement (QName "m" Nothing (Just "a14")) element of
+    Just _ ->
+      mknode "mc:AlternateContent"
+         [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
+         ] [ mknode "mc:Choice"
+             [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
+             , ("Requires", "a14")] [ element ]
+           ]
+    Nothing -> element
+
+paragraphToElement :: PandocMonad m => Paragraph -> P m Element
+paragraphToElement par = do
+  let
+    attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++
+            (case pPropMarginLeft (paraProps par) of
+               Just px -> [("marL", show $ 12700 * px), ("indent", "0")]
+               Nothing -> []
+            ) ++
+            (case pPropAlign (paraProps par) of
+               Just AlgnLeft -> [("algn", "l")]
+               Just AlgnRight -> [("algn", "r")]
+               Just AlgnCenter -> [("algn", "ctr")]
+               Nothing -> []
+            )
+    props = [] ++
+            (case pPropSpaceBefore $ paraProps par of
+               Just px -> [mknode "a:spcBef" [] [
+                              mknode "a:spcPts" [("val", show $ 100 * px)] ()
+                              ]
+                          ]
+               Nothing -> []
+            ) ++
+            (case pPropBullet $ paraProps par of
+               Just Bullet -> []
+               Just (AutoNumbering attrs') ->
+                 [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]
+               Nothing -> [mknode "a:buNone" [] ()]
+            )
+  paras <- mapM paraElemToElement (paraElems par)
+  return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras
+
+shapeToElement :: PandocMonad m => Element -> Shape -> P m Element
+shapeToElement layout (TextBox paras)
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      sp <- getContentShape ns spTree
+      elements <- mapM paragraphToElement paras
+      let txBody = mknode "p:txBody" [] $
+                   [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
+          emptySpPr = mknode "p:spPr" [] ()
+      return $
+        surroundWithMathAlternate $
+        replaceNamedChildren ns "p" "txBody" [txBody] $
+        replaceNamedChildren ns "p" "spPr" [emptySpPr] $
+        sp
+-- GraphicFrame and Pic should never reach this.
+shapeToElement _ _ = return $ mknode "p:sp" [] ()
+
+shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
+shapeToElements layout (Pic picProps fp attr alt) = do
+  mInfo <- registerMedia fp alt
+  case mInfoExt mInfo of
+    Just _ -> do
+      makePicElements layout picProps mInfo attr alt
+    Nothing -> shapeToElements layout $ TextBox [Paragraph def alt]
+shapeToElements layout (GraphicFrame tbls cptn) =
+  graphicFrameToElements layout tbls cptn
+shapeToElements layout shp = do
+  element <- shapeToElement layout shp
+  return [element]
+
+shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]
+shapesToElements layout shps = do
+ concat <$> mapM (shapeToElements layout) shps
+
+hardcodedTableMargin :: Integer
+hardcodedTableMargin = 36
+
+graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]
+graphicFrameToElements layout tbls caption = do
+  -- get the sizing
+  master <- getMaster
+  (pageWidth, pageHeight) <- asks envPresentationSize
+  let ns = elemToNameSpaces layout
+  ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
+                           `catchError`
+                           (\_ -> return ((0, 0), (pageWidth, pageHeight)))
+
+  let cy = if (not $ null caption) then cytmp - captionHeight else cytmp
+
+  elements <- mapM graphicToElement tbls
+  let graphicFrameElts =
+        mknode "p:graphicFrame" [] $
+        [ mknode "p:nvGraphicFramePr" [] $
+          [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
+          , mknode "p:cNvGraphicFramePr" [] $
+            [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
+          , mknode "p:nvPr" [] $
+            [mknode "p:ph" [("idx", "1")] ()]
+          ]
+        , mknode "p:xfrm" [] $
+          [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()
+          , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()
+          ]
+        ] ++ elements
+
+  if (not $ null caption)
+    then do capElt <- createCaption ((x, y), (cx, cytmp)) caption
+            return [graphicFrameElts, capElt]
+    else return [graphicFrameElts]
+
+graphicToElement :: PandocMonad m => Graphic -> P m Element
+graphicToElement (Tbl tblPr hdrCells rows) = do
+  (pageWidth, _) <- asks envPresentationSize
+  let colWidths = if null hdrCells
+                  then case rows of
+                         r : _ | not (null r) -> replicate (length r) $
+                                                (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length 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 replicate (length hdrCells) $
+                       (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)
+
+  let cellToOpenXML paras =
+        do elements <- mapM paragraphToElement paras
+           let elements' = if null elements
+                           then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]
+                           else elements
+           return $
+             [mknode "a:txBody" [] $
+               ([ mknode "a:bodyPr" [] ()
+                , mknode "a:lstStyle" [] ()]
+                 ++ elements')]
+  headers' <- mapM cellToOpenXML hdrCells
+  rows' <- mapM (mapM cellToOpenXML) rows
+  let borderProps = mknode "a:tcPr" [] ()
+  let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]
+  let mkcell border contents = mknode "a:tc" []
+                            $ (if null contents
+                               then emptyCell
+                               else contents) ++ [ borderProps | border ]
+  let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells
+
+  let mkgridcol w = mknode "a:gridCol"
+                       [("w", show ((12700 * w) :: Integer))] ()
+  let hasHeader = not (all null hdrCells)
+  return $ mknode "a:graphic" [] $
+    [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $
+     [mknode "a:tbl" [] $
+      [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")
+                         , ("bandRow", if tblPrBandRow tblPr then "1" else "0")
+                         ] ()
+      , mknode "a:tblGrid" [] (if all (==0) colWidths
+                               then []
+                               else map mkgridcol colWidths)
+      ]
+      ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'
+     ]
+    ]
+
+getShapeByName :: NameSpaces -> Element -> String -> Maybe Element
+getShapeByName ns spTreeElem name
+  | isElem ns "p" "spTree" spTreeElem =
+  filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem
+  | otherwise = Nothing
+
+-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element
+-- getShapeById ns spTreeElem ident
+--   | isElem ns "p" "spTree" spTreeElem =
+--   filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem
+--   | otherwise = Nothing
+
+nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element
+nonBodyTextToElement layout shapeName paraElements
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld
+  , Just sp <- getShapeByName ns spTree shapeName = do
+      let hdrPara = Paragraph def paraElements
+      element <- paragraphToElement hdrPara
+      let txBody = mknode "p:txBody" [] $
+                   [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
+                   [element]
+      return $ replaceNamedChildren ns "p" "txBody" [txBody] sp
+  -- XXX: TODO
+  | otherwise = return $ mknode "p:sp" [] ()
+
+contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element
+contentToElement layout hdrShape shapes
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      element <- nonBodyTextToElement layout "Title 1" hdrShape
+      let hdrShapeElements = if null hdrShape
+                             then []
+                             else [element]
+      contentElements <- local
+                         (\env -> env {envContentType = NormalContent})
+                         (shapesToElements layout shapes)
+      return $
+        replaceNamedChildren ns "p" "sp"
+        (hdrShapeElements ++ contentElements)
+        spTree
+contentToElement _ _ _ = return $ mknode "p:sp" [] ()
+
+twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
+twoColumnToElement layout hdrShape shapesL shapesR
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      element <- nonBodyTextToElement layout "Title 1" hdrShape
+      let hdrShapeElements = if null hdrShape
+                             then []
+                             else [element]
+      contentElementsL <- local
+                          (\env -> env {envContentType =TwoColumnLeftContent})
+                          (shapesToElements layout shapesL)
+      contentElementsR <- local
+                          (\env -> env {envContentType =TwoColumnRightContent})
+                          (shapesToElements layout shapesR)
+      -- let contentElementsL' = map (setIdx ns "1") contentElementsL
+      --     contentElementsR' = map (setIdx ns "2") contentElementsR
+      return $
+        replaceNamedChildren ns "p" "sp"
+        (hdrShapeElements ++ contentElementsL ++ contentElementsR)
+        spTree
+twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()
+
+
+titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
+titleToElement layout titleElems
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      element <- nonBodyTextToElement layout "Title 1" titleElems
+      let titleShapeElements = if null titleElems
+                               then []
+                               else [element]
+      return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree
+titleToElement _ _ = return $ mknode "p:sp" [] ()
+
+metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element
+metadataToElement layout titleElems subtitleElems authorsElems dateElems
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      titleShapeElements <- if null titleElems
+                            then return []
+                            else sequence [nonBodyTextToElement layout "Title 1" titleElems]
+      let combinedAuthorElems = intercalate [Break] authorsElems
+          subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]
+      subtitleShapeElements <- if null subtitleAndAuthorElems
+                               then return []
+                               else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]
+      dateShapeElements <- if null dateElems
+                           then return []
+                           else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]
+      return $ replaceNamedChildren ns "p" "sp"
+        (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)
+        spTree
+metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()
+
+slideToElement :: PandocMonad m => Slide -> P m Element
+slideToElement s@(ContentSlide hdrElems shapes) = do
+  layout <- getLayout s
+  spTree <- local (\env -> if null hdrElems
+                           then env
+                           else env{envSlideHasHeader=True}) $
+            contentToElement layout hdrElems shapes
+  return $ 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")
+    ] [mknode "p:cSld" [] [spTree]]
+slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do
+  layout <- getLayout s
+  spTree <- local (\env -> if null hdrElems
+                           then env
+                           else env{envSlideHasHeader=True}) $
+            twoColumnToElement layout hdrElems shapesL shapesR
+  return $ 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")
+    ] [mknode "p:cSld" [] [spTree]]
+slideToElement s@(TitleSlide hdrElems) = do
+  layout <- getLayout s
+  spTree <- titleToElement layout hdrElems
+  return $ 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")
+    ] [mknode "p:cSld" [] [spTree]]
+slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do
+  layout <- getLayout s
+  spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems
+  return $ 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")
+    ] [mknode "p:cSld" [] [spTree]]
+
+-----------------------------------------------------------------------
+
+slideToFilePath :: Slide -> Int -> FilePath
+slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"
+
+slideToSlideId :: Monad m => Slide -> Int -> P m String
+slideToSlideId _ idNum = do
+  n <- asks envSlideIdOffset
+  return $ "rId" ++ (show $ idNum + n)
+
+
+data Relationship = Relationship { relId :: Int
+                                 , relType :: MimeType
+                                 , relTarget :: FilePath
+                                 } deriving (Show, Eq)
+
+elementToRel :: Element -> Maybe Relationship
+elementToRel element
+  | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =
+      do rId <- findAttr (QName "Id" Nothing Nothing) element
+         numStr <- stripPrefix "rId" rId
+         num <- case reads numStr :: [(Int, String)] of
+           (n, _) : _ -> Just n
+           []         -> Nothing
+         type' <- findAttr (QName "Type" Nothing Nothing) element
+         target <- findAttr (QName "Target" Nothing Nothing) element
+         return $ Relationship num type' target
+  | otherwise = Nothing
+
+slideToPresRel :: Monad m => Slide -> Int -> P m Relationship
+slideToPresRel slide idNum = do
+  n <- asks envSlideIdOffset
+  let rId = idNum + n
+      fp = "slides/" ++ slideToFilePath slide idNum
+  return $ Relationship { relId = rId
+                        , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
+                        , relTarget = fp
+                        }
+
+getRels :: PandocMonad m => P m [Relationship]
+getRels = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"
+  let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
+  let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem
+  return $ mapMaybe elementToRel relElems
+
+presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
+presentationToRels (Presentation slides) = do
+  mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]
+  rels <- getRels
+  let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
+  -- We want to make room for the slides in the id space. The slides
+  -- will start at Id2 (since Id1 is for the slide master). There are
+  -- two slides in the data file, but that might change in the future,
+  -- so we will do this:
+  --
+  -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.
+  -- 2. We add the difference between this and the number of slides to
+  -- all relWithoutSlide rels (unless they're 1)
+
+  let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of
+        [] -> 0                 -- doesn't matter in this case, since
+                                -- there will be nothing to map the
+                                -- function over
+        l  -> minimum l
+
+      modifyRelNum :: Int -> Int
+      modifyRelNum 1 = 1
+      modifyRelNum n = n - minRelNotOne + 2 + length slides
+
+      relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides
+
+  return $ mySlideRels ++ relsWithoutSlides'
+
+relToElement :: Relationship -> Element
+relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))
+                                         , ("Type", relType rel)
+                                         , ("Target", relTarget rel) ] ()
+
+relsToElement :: [Relationship] -> Element
+relsToElement rels = mknode "Relationships"
+                     [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
+                     (map relToElement rels)
+
+presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry
+presentationToRelsEntry pres = do
+  rels <- presentationToRels pres
+  elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels
+
+elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
+elemToEntry fp element = do
+  epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
+  return $ toEntry fp epochtime $ renderXml element
+
+slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry
+slideToEntry slide idNum = do
+  local (\env -> env{envCurSlideId = idNum}) $ do
+    element <- slideToElement slide
+    elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element
+
+slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
+slideToSlideRelEntry slide idNum = do
+  element <- slideToSlideRelElement slide idNum
+  elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
+
+linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element)
+linkRelElement idNum (url, _) = do
+  anchorMap <- gets stAnchorMap
+  case url of
+    -- if it's an anchor in the map, we use the slide number for an
+    -- internal link.
+    '#' : anchor | Just num <- M.lookup anchor anchorMap ->
+      return $ Just $
+      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
+                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
+                            , ("Target", "slide" ++ show num ++ ".xml")
+                            ] ()
+    -- if it's an anchor not in the map, we return nothing.
+    '#' : _ -> return Nothing
+    -- Anything else we treat as an external link
+    _ ->
+      return $ Just $
+      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
+                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
+                        , ("Target", url)
+                        , ("TargetMode", "External")
+                        ] ()
+
+linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]
+linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
+
+mediaRelElement :: MediaInfo -> Element
+mediaRelElement mInfo =
+  let ext = case mInfoExt mInfo of
+              Just e -> e
+              Nothing -> ""
+  in
+    mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))
+                          , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
+                          , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
+                          ] ()
+
+slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element
+slideToSlideRelElement slide idNum = do
+  let target =  case slide of
+        (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"
+        (TitleSlide _)        -> "../slideLayouts/slideLayout3.xml"
+        (ContentSlide _ _)    -> "../slideLayouts/slideLayout2.xml"
+        (TwoColumnSlide _ _ _)    -> "../slideLayouts/slideLayout4.xml"
+
+  linkIds <- gets stLinkIds
+  mediaIds <- gets stMediaIds
+
+  linkRels <- case M.lookup idNum linkIds of
+                Just mp -> linkRelElements mp
+                Nothing -> return []
+  let mediaRels = case M.lookup idNum mediaIds of
+                   Just mInfos -> map mediaRelElement mInfos
+                   Nothing -> []
+
+  return $
+    mknode "Relationships"
+    [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
+    ([mknode "Relationship" [ ("Id", "rId1")
+                           , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
+                           , ("Target", target)] ()
+    ] ++ linkRels ++ mediaRels)
+
+slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element
+slideToSldIdElement slide idNum = do
+  let id' = show $ idNum + 255
+  rId <- slideToSlideId slide idNum
+  return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
+
+presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
+presentationToSldIdLst (Presentation slides) = do
+  ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
+  return $ mknode "p:sldIdLst" [] ids
+
+presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
+presentationToPresentationElement pres = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  element <- parseXml refArchive distArchive "ppt/presentation.xml"
+  sldIdLst <- presentationToSldIdLst pres
+
+  let modifySldIdLst :: Content -> Content
+      modifySldIdLst (Elem e) = case elName e of
+        (QName "sldIdLst" _ _) -> Elem sldIdLst
+        _                      -> Elem e
+      modifySldIdLst ct = ct
+
+      newContent = map modifySldIdLst $ elContent element
+
+  return $ element{elContent = newContent}
+
+presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry
+presentationToPresEntry pres = presentationToPresentationElement pres >>=
+  elemToEntry "ppt/presentation.xml"
+
+
+
+
+defaultContentTypeToElem :: DefaultContentType -> Element
+defaultContentTypeToElem dct =
+  mknode "Default"
+  [("Extension", defContentTypesExt dct),
+    ("ContentType", defContentTypesType dct)]
+  ()
+
+overrideContentTypeToElem :: OverrideContentType -> Element
+overrideContentTypeToElem oct =
+  mknode "Override"
+  [("PartName", overrideContentTypesPart oct),
+    ("ContentType", overrideContentTypesType oct)]
+  ()
+
+contentTypesToElement :: ContentTypes -> Element
+contentTypesToElement ct =
+  let ns = "http://schemas.openxmlformats.org/package/2006/content-types"
+  in
+    mknode "Types" [("xmlns", ns)] $
+    (map defaultContentTypeToElem $ contentTypesDefaults ct) ++
+    (map overrideContentTypeToElem $ contentTypesOverrides ct)
+
+data DefaultContentType = DefaultContentType
+                           { defContentTypesExt :: String
+                           , defContentTypesType:: MimeType
+                           }
+                         deriving (Show, Eq)
+
+data OverrideContentType = OverrideContentType
+                           { overrideContentTypesPart :: FilePath
+                           , overrideContentTypesType :: MimeType
+                           }
+                          deriving (Show, Eq)
+
+data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]
+                                 , contentTypesOverrides :: [OverrideContentType]
+                                 }
+                    deriving (Show, Eq)
+
+contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
+contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct
+
+pathToOverride :: FilePath -> Maybe OverrideContentType
+pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
+
+mediaFileContentType :: FilePath -> Maybe DefaultContentType
+mediaFileContentType fp = case takeExtension fp of
+  '.' : ext -> Just $
+               DefaultContentType { defContentTypesExt = ext
+                                  , defContentTypesType =
+                                      case getMimeType fp of
+                                        Just mt -> mt
+                                        Nothing -> "application/octet-stream"
+                                  }
+  _ -> Nothing
+
+mediaContentType :: MediaInfo -> Maybe DefaultContentType
+mediaContentType mInfo
+  | Just ('.' : ext) <- mInfoExt mInfo =
+      Just $ DefaultContentType { defContentTypesExt = ext
+                                , defContentTypesType =
+                                    case mInfoMimeType mInfo of
+                                      Just mt -> mt
+                                      Nothing -> "application/octet-stream"
+                                }
+  | otherwise = Nothing
+
+presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
+presentationToContentTypes (Presentation slides) = do
+  mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
+  filePaths <- patternsToFilePaths inheritedPatterns
+  let mediaFps = filter (match (compile "ppt/media/image*")) filePaths
+  let defaults = [ DefaultContentType "xml" "application/xml"
+                 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
+                 ]
+      mediaDefaults = nub $
+                      (mapMaybe mediaContentType $ mediaInfos) ++
+                      (mapMaybe mediaFileContentType $ mediaFps)
+
+      inheritedOverrides = mapMaybe pathToOverride filePaths
+      presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
+      slideOverrides =
+        mapMaybe
+        (\(s, n) ->
+           pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)
+        (zip slides [1..])
+      -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]
+  return $ ContentTypes
+    (defaults ++ mediaDefaults)
+    (inheritedOverrides ++ presOverride ++ slideOverrides)
+
+presML :: String
+presML = "application/vnd.openxmlformats-officedocument.presentationml"
+
+noPresML :: String
+noPresML = "application/vnd.openxmlformats-officedocument"
+
+getContentType :: FilePath -> Maybe MimeType
+getContentType fp
+  | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"
+  | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"
+  | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"
+  | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"
+  | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"
+  | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"
+  | "ppt" : "slideMasters" : f : [] <- splitDirectories fp
+  , (_, ".xml") <- splitExtension f =
+      Just $ presML ++ ".slideMaster+xml"
+  | "ppt" : "slides" : f : [] <- splitDirectories fp
+  , (_, ".xml") <- splitExtension f =
+      Just $ presML ++ ".slide+xml"
+  | "ppt" : "notesMasters"  : f : [] <- splitDirectories fp
+  , (_, ".xml") <- splitExtension f =
+      Just $ presML ++ ".notesMaster+xml"
+  | "ppt" : "notesSlides"  : f : [] <- splitDirectories fp
+  , (_, ".xml") <- splitExtension f =
+      Just $ presML ++ ".notesSlide+xml"
+  | "ppt" : "theme" : f : [] <- splitDirectories fp
+  , (_, ".xml") <- splitExtension f =
+      Just $ noPresML ++ ".theme+xml"
+  | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=
+      Just $ presML ++ ".slideLayout+xml"
+  | otherwise = Nothing
+
+autoNumberingToType :: ListAttributes -> String
+autoNumberingToType (_, numStyle, numDelim) =
+  typeString ++ delimString
+  where
+    typeString = case numStyle of
+      Decimal -> "arabic"
+      UpperAlpha -> "alphaUc"
+      LowerAlpha -> "alphaLc"
+      UpperRoman -> "romanUc"
+      LowerRoman -> "romanLc"
+      _          -> "arabic"
+    delimString = case numDelim of
+      Period -> "Period"
+      OneParen -> "ParenR"
+      TwoParens -> "ParenBoth"
+      _         -> "Period"
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
new file mode 100644
index 000000000..68b2aeeb2
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -0,0 +1,701 @@
+{-# LANGUAGE PatternGuards #-}
+
+{-
+Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module      : Text.Pandoc.Writers.Powerpoint.Presentation
+   Copyright   : Copyright (C) 2017-2018 Jesse Rosenthal
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
+   Stability   : alpha
+   Portability : portable
+
+Definition of Presentation datatype, modeling a MS Powerpoint (pptx)
+document, and functions for converting a Pandoc document to
+Presentation.
+-}
+
+module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation
+                                                   , Presentation(..)
+                                                   , Slide(..)
+                                                   , SlideElement(..)
+                                                   , Shape(..)
+                                                   , Graphic(..)
+                                                   , BulletType(..)
+                                                   , Algnment(..)
+                                                   , Paragraph(..)
+                                                   , ParaElem(..)
+                                                   , ParaProps(..)
+                                                   , RunProps(..)
+                                                   , TableProps(..)
+                                                   , Strikethrough(..)
+                                                   , Capitals(..)
+                                                   , PicProps(..)
+                                                   , URL
+                                                   , TeXString(..)
+                                                   ) where
+
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.List (intercalate)
+import Data.Default
+import Text.Pandoc.Definition
+import Text.Pandoc.Class (PandocMonad)
+import Text.Pandoc.Slides (getSlideLevel)
+import qualified Text.Pandoc.Class as P
+import Text.Pandoc.Options
+import Text.Pandoc.Logging
+import Text.Pandoc.Walk
+import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
+import Text.Pandoc.Writers.Shared (metaValueToInlines)
+import qualified Data.Map as M
+import Data.Maybe (maybeToList)
+
+data WriterEnv = WriterEnv { envMetadata :: Meta
+                           , envRunProps :: RunProps
+                           , envParaProps :: ParaProps
+                           , envSlideLevel :: Int
+                           , envOpts :: WriterOptions
+                           , envSlideHasHeader :: Bool
+                           , envInList :: Bool
+                           , envInNoteSlide :: Bool
+                           , envCurSlideId :: Int
+                           -- the difference between the number at
+                           -- the end of the slide file name and
+                           -- the rId number
+                           , envSlideIdOffset :: Int
+                           }
+                 deriving (Show)
+
+instance Default WriterEnv where
+  def = WriterEnv { envMetadata = mempty
+                  , envRunProps = def
+                  , envParaProps = def
+                  , envSlideLevel = 2
+                  , envOpts = def
+                  , envSlideHasHeader = False
+                  , envInList = False
+                  , envInNoteSlide = False
+                  , envCurSlideId = 1
+                  , envSlideIdOffset = 1
+                  }
+
+
+data WriterState = WriterState { stNoteIds :: M.Map Int [Block]
+                               -- associate anchors with slide id
+                               , stAnchorMap :: M.Map String Int
+                               } deriving (Show, Eq)
+
+instance Default WriterState where
+  def = WriterState { stNoteIds = mempty
+                    , stAnchorMap= mempty
+                    }
+
+type Pres m = ReaderT WriterEnv (StateT WriterState m)
+
+runPres :: Monad m => WriterEnv -> WriterState -> Pres m a -> m a
+runPres env st p = evalStateT (runReaderT p env) st
+
+-- GHC 7.8 will still complain about concat <$> mapM unless we specify
+-- Functor. We can get rid of this when we stop supporting GHC 7.8.
+concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
+concatMapM f xs   =  liftM concat (mapM f xs)
+
+type Pixels = Integer
+
+data Presentation = Presentation [Slide]
+  deriving (Show)
+
+data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
+                            , metadataSlideSubtitle :: [ParaElem]
+                            , metadataSlideAuthors :: [[ParaElem]]
+                            , metadataSlideDate :: [ParaElem]
+                            }
+           | TitleSlide { titleSlideHeader :: [ParaElem]}
+           | ContentSlide { contentSlideHeader :: [ParaElem]
+                          , contentSlideContent :: [Shape]
+                          }
+           | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]
+                            , twoColumnSlideLeft   :: [Shape]
+                            , twoColumnSlideRight  :: [Shape]
+                            }
+           deriving (Show, Eq)
+
+data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape
+  deriving (Show, Eq)
+
+data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]
+           | GraphicFrame [Graphic] [ParaElem]
+           | TextBox [Paragraph]
+  deriving (Show, Eq)
+
+type Cell = [Paragraph]
+
+data TableProps = TableProps { tblPrFirstRow :: Bool
+                             , tblPrBandRow :: Bool
+                             } deriving (Show, Eq)
+
+data Graphic = Tbl TableProps [Cell] [[Cell]]
+  deriving (Show, Eq)
+
+
+data Paragraph = Paragraph { paraProps :: ParaProps
+                           , paraElems  :: [ParaElem]
+                           } deriving (Show, Eq)
+
+
+data BulletType = Bullet
+                | AutoNumbering ListAttributes
+  deriving (Show, Eq)
+
+data Algnment = AlgnLeft | AlgnRight | AlgnCenter
+  deriving (Show, Eq)
+
+data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels
+                           , pPropMarginRight :: Maybe Pixels
+                           , pPropLevel :: Int
+                           , pPropBullet :: Maybe BulletType
+                           , pPropAlign :: Maybe Algnment
+                           , pPropSpaceBefore :: Maybe Pixels
+                           } deriving (Show, Eq)
+
+instance Default ParaProps where
+  def = ParaProps { pPropMarginLeft = Just 0
+                  , pPropMarginRight = Just 0
+                  , pPropLevel = 0
+                  , pPropBullet = Nothing
+                  , pPropAlign = Nothing
+                  , pPropSpaceBefore = Nothing
+                  }
+
+newtype TeXString = TeXString {unTeXString :: String}
+  deriving (Eq, Show)
+
+data ParaElem = Break
+              | Run RunProps String
+              -- It would be more elegant to have native TeXMath
+              -- Expressions here, but this allows us to use
+              -- `convertmath` from T.P.Writers.Math. Will perhaps
+              -- revisit in the future.
+              | MathElem MathType TeXString
+              deriving (Show, Eq)
+
+data Strikethrough = NoStrike | SingleStrike | DoubleStrike
+  deriving (Show, Eq)
+
+data Capitals = NoCapitals | SmallCapitals | AllCapitals
+  deriving (Show, Eq)
+
+type URL = String
+
+data RunProps = RunProps { rPropBold :: Bool
+                         , rPropItalics :: Bool
+                         , rStrikethrough :: Maybe Strikethrough
+                         , rBaseline :: Maybe Int
+                         , rCap :: Maybe Capitals
+                         , rLink :: Maybe (URL, String)
+                         , rPropCode :: Bool
+                         , rPropBlockQuote :: Bool
+                         , rPropForceSize :: Maybe Pixels
+                         } deriving (Show, Eq)
+
+instance Default RunProps where
+  def = RunProps { rPropBold = False
+                 , rPropItalics = False
+                 , rStrikethrough = Nothing
+                 , rBaseline = Nothing
+                 , rCap = Nothing
+                 , rLink = Nothing
+                 , rPropCode = False
+                 , rPropBlockQuote = False
+                 , rPropForceSize = Nothing
+                 }
+
+data PicProps = PicProps { picPropLink :: Maybe (URL, String)
+                         } deriving (Show, Eq)
+
+instance Default PicProps where
+  def = PicProps { picPropLink = Nothing
+                 }
+
+--------------------------------------------------
+
+inlinesToParElems :: Monad m => [Inline] -> Pres m [ParaElem]
+inlinesToParElems ils = concatMapM inlineToParElems ils
+
+inlineToParElems :: Monad m => Inline -> Pres m [ParaElem]
+inlineToParElems (Str s) = do
+  pr <- asks envRunProps
+  return [Run pr s]
+inlineToParElems (Emph ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $
+  inlinesToParElems ils
+inlineToParElems (Strong ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $
+  inlinesToParElems ils
+inlineToParElems (Strikeout ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $
+  inlinesToParElems ils
+inlineToParElems (Superscript ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $
+  inlinesToParElems ils
+inlineToParElems (Subscript ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $
+  inlinesToParElems ils
+inlineToParElems (SmallCaps ils) =
+  local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $
+  inlinesToParElems ils
+inlineToParElems Space = inlineToParElems (Str " ")
+inlineToParElems SoftBreak = inlineToParElems (Str " ")
+inlineToParElems LineBreak = return [Break]
+inlineToParElems (Link _ ils (url, title)) = do
+  local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $
+    inlinesToParElems ils
+inlineToParElems (Code _ str) = do
+  local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $
+    inlineToParElems $ Str str
+inlineToParElems (Math mathtype str) =
+  return [MathElem mathtype (TeXString str)]
+inlineToParElems (Note blks) = do
+  notes <- gets stNoteIds
+  let maxNoteId = case M.keys notes of
+        [] -> 0
+        lst -> maximum lst
+      curNoteId = maxNoteId + 1
+  modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }
+  inlineToParElems $ Superscript [Str $ show curNoteId]
+inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils
+inlineToParElems (RawInline _ _) = return []
+inlineToParElems _ = return []
+
+isListType :: Block -> Bool
+isListType (OrderedList _ _) = True
+isListType (BulletList _) = True
+isListType (DefinitionList _) = True
+isListType _ = False
+
+registerAnchorId :: PandocMonad m => String -> Pres m ()
+registerAnchorId anchor = do
+  anchorMap <- gets stAnchorMap
+  slideId <- asks envCurSlideId
+  unless (null anchor) $
+    modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
+
+-- Currently hardcoded, until I figure out how to make it dynamic.
+blockQuoteSize :: Pixels
+blockQuoteSize = 20
+
+noteSize :: Pixels
+noteSize = 18
+
+blockToParagraphs :: PandocMonad m => Block -> Pres m [Paragraph]
+blockToParagraphs (Plain ils) = do
+  parElems <- inlinesToParElems ils
+  pProps <- asks envParaProps
+  return [Paragraph pProps parElems]
+blockToParagraphs (Para ils) = do
+  parElems <- inlinesToParElems ils
+  pProps <- asks envParaProps
+  return [Paragraph pProps parElems]
+blockToParagraphs (LineBlock ilsList) = do
+  parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList
+  pProps <- asks envParaProps
+  return [Paragraph pProps parElems]
+-- TODO: work out the attributes
+blockToParagraphs (CodeBlock attr str) =
+  local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $
+  blockToParagraphs $ Para [Code attr str]
+-- We can't yet do incremental lists, but we should render a
+-- (BlockQuote List) as a list to maintain compatibility with other
+-- formats.
+blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do
+  ps  <- blockToParagraphs blk
+  ps' <- blockToParagraphs $ BlockQuote blks
+  return $ ps ++ ps'
+blockToParagraphs (BlockQuote blks) =
+  local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
+                , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$
+  concatMapM blockToParagraphs blks
+-- TODO: work out the format
+blockToParagraphs (RawBlock _ _) = return []
+blockToParagraphs (Header _ (ident, _, _) ils) = do
+  -- Note that this function only deals with content blocks, so it
+  -- will only touch headers that are above the current slide level --
+  -- slides at or below the slidelevel will be taken care of by
+  -- `blocksToSlide'`. We have the register anchors in both of them.
+  registerAnchorId ident
+  -- we set the subeader to bold
+  parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $
+              inlinesToParElems ils
+  -- and give it a bit of space before it.
+  return [Paragraph def{pPropSpaceBefore = Just 30} parElems]
+blockToParagraphs (BulletList blksLst) = do
+  pProps <- asks envParaProps
+  let lvl = pPropLevel pProps
+  local (\env -> env{ envInList = True
+                    , envParaProps = pProps{ pPropLevel = lvl + 1
+                                           , pPropBullet = Just Bullet
+                                           , pPropMarginLeft = Nothing
+                                           }}) $
+    concatMapM multiParBullet blksLst
+blockToParagraphs (OrderedList listAttr blksLst) = do
+  pProps <- asks envParaProps
+  let lvl = pPropLevel pProps
+  local (\env -> env{ envInList = True
+                    , envParaProps = pProps{ pPropLevel = lvl + 1
+                                           , pPropBullet = Just (AutoNumbering listAttr)
+                                           , pPropMarginLeft = Nothing
+                                           }}) $
+    concatMapM multiParBullet blksLst
+blockToParagraphs (DefinitionList entries) = do
+  let go :: PandocMonad m => ([Inline], [[Block]]) -> Pres m [Paragraph]
+      go (ils, blksLst) = do
+        term <-blockToParagraphs $ Para [Strong ils]
+        -- For now, we'll treat each definition term as a
+        -- blockquote. We can extend this further later.
+        definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst
+        return $ term ++ definition
+  concatMapM go entries
+blockToParagraphs (Div (_, ("notes" : []), _) _) = return []
+blockToParagraphs (Div _ blks)  = concatMapM blockToParagraphs blks
+blockToParagraphs blk = do
+  P.report $ BlockNotRendered blk
+  return []
+
+-- Make sure the bullet env gets turned off after the first para.
+multiParBullet :: PandocMonad m => [Block] -> Pres m [Paragraph]
+multiParBullet [] = return []
+multiParBullet (b:bs) = do
+  pProps <- asks envParaProps
+  p <- blockToParagraphs b
+  ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $
+    concatMapM blockToParagraphs bs
+  return $ p ++ ps
+
+cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> Pres m [Paragraph]
+cellToParagraphs algn tblCell = do
+  paras <- mapM (blockToParagraphs) tblCell
+  let alignment = case algn of
+        AlignLeft -> Just AlgnLeft
+        AlignRight -> Just AlgnRight
+        AlignCenter -> Just AlgnCenter
+        AlignDefault -> Nothing
+      paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
+  return $ concat paras'
+
+rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> Pres m [[Paragraph]]
+rowToParagraphs algns tblCells = do
+  -- We have to make sure we have the right number of alignments
+  let pairs = zip (algns ++ repeat AlignDefault) tblCells
+  mapM (\(a, tc) -> cellToParagraphs a tc) pairs
+
+blockToShape :: PandocMonad m => Block -> Pres m Shape
+blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =
+      Pic def url attr <$> (inlinesToParElems ils)
+blockToShape (Para (il:_))  | Image attr ils (url, _) <- il =
+      Pic def url attr <$> (inlinesToParElems ils)
+blockToShape (Plain (il:_)) | Link _ (il':_) target <- il
+                            , Image attr ils (url, _) <- il' =
+      Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
+blockToShape (Para (il:_))  | Link _ (il':_) target <- il
+                            , Image attr ils (url, _) <- il' =
+      Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
+blockToShape (Table caption algn _ hdrCells rows) = do
+  caption' <- inlinesToParElems caption
+  hdrCells' <- rowToParagraphs algn hdrCells
+  rows' <- mapM (rowToParagraphs algn) rows
+  let tblPr = if null hdrCells
+              then TableProps { tblPrFirstRow = False
+                              , tblPrBandRow = True
+                              }
+              else TableProps { tblPrFirstRow = True
+                              , tblPrBandRow = True
+                              }
+
+  return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption'
+blockToShape blk = do paras <- blockToParagraphs blk
+                      let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras
+                      return $ TextBox paras'
+
+combineShapes :: [Shape] -> [Shape]
+combineShapes [] = []
+combineShapes (s : []) = [s]
+combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss
+combineShapes ((TextBox []) : ss) = combineShapes ss
+combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)
+combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =
+  combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
+combineShapes (s:ss) = s : combineShapes ss
+
+blocksToShapes :: PandocMonad m => [Block] -> Pres m [Shape]
+blocksToShapes blks = combineShapes <$> mapM blockToShape blks
+
+isImage :: Inline -> Bool
+isImage (Image _ _ _) = True
+isImage (Link _ ((Image _ _ _) : _) _) = True
+isImage _ = False
+
+splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> Pres m [[Block]]
+splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])
+splitBlocks' cur acc (HorizontalRule : blks) =
+  splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks
+splitBlocks' cur acc (h@(Header n _ _) : blks) = do
+  slideLevel <- asks envSlideLevel
+  case compare n slideLevel of
+    LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks
+    EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks
+    GT -> splitBlocks' (cur ++ [h]) acc blks
+-- `blockToParagraphs` treats Plain and Para the same, so we can save
+-- some code duplication by treating them the same here.
+splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)
+splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do
+  slideLevel <- asks envSlideLevel
+  case cur of
+    (Header n _ _) : [] | n == slideLevel ->
+                            splitBlocks' []
+                            (acc ++ [cur ++ [Para [il]]])
+                            (if null ils then blks else (Para ils) : blks)
+    _ -> splitBlocks' []
+         (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])
+         (if null ils then blks else (Para ils) : blks)
+splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do
+  slideLevel <- asks envSlideLevel
+  case cur of
+    (Header n _ _) : [] | n == slideLevel ->
+                            splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks
+    _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks
+splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes =  do
+  slideLevel <- asks envSlideLevel
+  case cur of
+    (Header n _ _) : [] | n == slideLevel ->
+                            splitBlocks' [] (acc ++ [cur ++ [d]]) blks
+    _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks
+splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks
+
+splitBlocks :: Monad m => [Block] -> Pres m [[Block]]
+splitBlocks = splitBlocks' [] []
+
+blocksToSlide' :: PandocMonad m => Int -> [Block] -> Pres m Slide
+blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
+  | n < lvl = do
+      registerAnchorId ident
+      hdr <- inlinesToParElems ils
+      return $ TitleSlide {titleSlideHeader = hdr}
+  | n == lvl = do
+      registerAnchorId ident
+      hdr <- inlinesToParElems ils
+      -- Now get the slide without the header, and then add the header
+      -- in.
+      slide <- blocksToSlide' lvl blks
+      return $ case slide of
+        ContentSlide _ cont          -> ContentSlide hdr cont
+        TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
+        slide'                       -> slide'
+blocksToSlide' _ (blk : blks)
+  | Div (_, classes, _) divBlks <- blk
+  , "columns" `elem` classes
+  , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks
+  , "column" `elem` clsL, "column" `elem` clsR = do
+      unless (null blks)
+        (mapM (P.report . BlockNotRendered) blks >> return ())
+      unless (null remaining)
+        (mapM (P.report . BlockNotRendered) remaining >> return ())
+      mbSplitBlksL <- splitBlocks blksL
+      mbSplitBlksR <- splitBlocks blksR
+      let blksL' = case mbSplitBlksL of
+            bs : _ -> bs
+            []     -> []
+      let blksR' = case mbSplitBlksR of
+            bs : _ -> bs
+            []     -> []
+      shapesL <- blocksToShapes blksL'
+      shapesR <- blocksToShapes blksR'
+      return $ TwoColumnSlide { twoColumnSlideHeader = []
+                              , twoColumnSlideLeft = shapesL
+                              , twoColumnSlideRight = shapesR
+                              }
+blocksToSlide' _ (blk : blks) = do
+      inNoteSlide <- asks envInNoteSlide
+      shapes <- if inNoteSlide
+                then forceFontSize noteSize $ blocksToShapes (blk : blks)
+                else blocksToShapes (blk : blks)
+      return $ ContentSlide { contentSlideHeader = []
+                            , contentSlideContent = shapes
+                            }
+blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []
+                                            , contentSlideContent = []
+                                            }
+
+blocksToSlide :: PandocMonad m => [Block] -> Pres m Slide
+blocksToSlide blks = do
+  slideLevel <- asks envSlideLevel
+  blocksToSlide' slideLevel blks
+
+makeNoteEntry :: Int -> [Block] -> [Block]
+makeNoteEntry n blks =
+  let enum = Str (show n ++ ".")
+  in
+    case blks of
+      (Para ils : blks') -> (Para $ enum : Space : ils) : blks'
+      _ -> (Para [enum]) : blks
+
+forceFontSize :: PandocMonad m => Pixels -> Pres m a -> Pres m a
+forceFontSize px x = do
+  rpr <- asks envRunProps
+  local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x
+
+-- We leave these as blocks because we will want to include them in
+-- the TOC.
+makeNotesSlideBlocks :: PandocMonad m => Pres m [Block]
+makeNotesSlideBlocks = do
+  noteIds <- gets stNoteIds
+  slideLevel <- asks envSlideLevel
+  meta <- asks envMetadata
+  -- Get identifiers so we can give the notes section a unique ident.
+  anchorSet <- M.keysSet <$> gets stAnchorMap
+  if M.null noteIds
+    then return []
+    else do let title = case lookupMeta "notes-title" meta of
+                  Just val -> metaValueToInlines val
+                  Nothing  -> [Str "Notes"]
+                ident = Shared.uniqueIdent title anchorSet
+                hdr = Header slideLevel (ident, [], []) title
+            blks <- return $
+                    concatMap (\(n, bs) -> makeNoteEntry n bs) $
+                    M.toList noteIds
+            return $ hdr : blks
+
+getMetaSlide :: PandocMonad m => Pres m (Maybe Slide)
+getMetaSlide  = do
+  meta <- asks envMetadata
+  title <- inlinesToParElems $ docTitle meta
+  subtitle <- inlinesToParElems $
+    case lookupMeta "subtitle" meta of
+      Just (MetaString s)           -> [Str s]
+      Just (MetaInlines ils)        -> ils
+      Just (MetaBlocks [Plain ils]) -> ils
+      Just (MetaBlocks [Para ils])  -> ils
+      _                             -> []
+  authors <- mapM inlinesToParElems $ docAuthors meta
+  date <- inlinesToParElems $ docDate meta
+  if null title && null subtitle && null authors && null date
+    then return Nothing
+    else return $ Just $ MetadataSlide { metadataSlideTitle = title
+                                       , metadataSlideSubtitle = subtitle
+                                       , metadataSlideAuthors = authors
+                                       , metadataSlideDate = date
+                                       }
+-- adapted from the markdown writer
+elementToListItem :: PandocMonad m => Shared.Element -> Pres m [Block]
+elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do
+  opts <- asks envOpts
+  let headerLink = if null ident
+                   then walk Shared.deNote headerText
+                   else [Link nullAttr (walk Shared.deNote headerText)
+                          ('#':ident, "")]
+  listContents <- if null subsecs || lev >= writerTOCDepth opts
+                  then return []
+                  else mapM elementToListItem subsecs
+  return [Plain headerLink, BulletList listContents]
+elementToListItem (Shared.Blk _) = return []
+
+makeTOCSlide :: PandocMonad m => [Block] -> Pres m Slide
+makeTOCSlide blks = do
+  contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)
+  meta <- asks envMetadata
+  slideLevel <- asks envSlideLevel
+  let tocTitle = case lookupMeta "toc-title" meta of
+                   Just val -> metaValueToInlines val
+                   Nothing  -> [Str "Table of Contents"]
+      hdr = Header slideLevel nullAttr tocTitle
+  sld <- blocksToSlide [hdr, contents]
+  return sld
+
+combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]
+combineParaElems' mbPElem [] = maybeToList mbPElem
+combineParaElems' Nothing (pElem : pElems) =
+  combineParaElems' (Just pElem) pElems
+combineParaElems' (Just pElem') (pElem : pElems)
+  | Run rPr' s' <- pElem'
+  , Run rPr s <- pElem
+  , rPr == rPr' =
+    combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems
+  | otherwise =
+    pElem' : combineParaElems' (Just pElem) pElems
+
+combineParaElems :: [ParaElem] -> [ParaElem]
+combineParaElems = combineParaElems' Nothing
+
+blocksToPresentation :: PandocMonad m => [Block] -> Pres m Presentation
+blocksToPresentation blks = do
+  opts <- asks envOpts
+  let metadataStartNum = 1
+  metadataslides <- maybeToList <$> getMetaSlide
+  let tocStartNum = metadataStartNum + length metadataslides
+  -- As far as I can tell, if we want to have a variable-length toc in
+  -- the future, we'll have to make it twice. Once to get the length,
+  -- and a second time to include the notes slide. We can't make the
+  -- notes slide before the body slides because we need to know if
+  -- there are notes, and we can't make either before the toc slide,
+  -- because we need to know its length to get slide numbers right.
+  --
+  -- For now, though, since the TOC slide is only length 1, if it
+  -- exists, we'll just get the length, and then come back to make the
+  -- slide later
+  let tocSlidesLength = if writerTableOfContents opts then 1 else 0
+  let bodyStartNum = tocStartNum + tocSlidesLength
+  blksLst <- splitBlocks blks
+  bodyslides <- mapM
+                (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs))
+                (zip blksLst [bodyStartNum..])
+  let noteStartNum = bodyStartNum + length bodyslides
+  notesSlideBlocks <- makeNotesSlideBlocks
+  -- now we come back and make the real toc...
+  tocSlides <- if writerTableOfContents opts
+               then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks
+                       return [toc]
+               else return []
+  -- ... and the notes slide. We test to see if the blocks are empty,
+  -- because we don't want to make an empty slide.
+  notesSlides <- if null notesSlideBlocks
+                 then return []
+                 else do notesSlide <- local
+                           (\env -> env { envCurSlideId = noteStartNum
+                                        , envInNoteSlide = True
+                                        })
+                           (blocksToSlide $ notesSlideBlocks)
+                         return [notesSlide]
+  return $
+    Presentation $
+    metadataslides ++ tocSlides ++ bodyslides ++ notesSlides
+
+documentToPresentation :: PandocMonad m
+                       => WriterOptions
+                       -> Pandoc
+                       -> m Presentation
+documentToPresentation opts (Pandoc meta blks) = do
+  let env = def { envOpts = opts
+                , envMetadata = meta
+                , envSlideLevel = case writerSlideLevel opts of
+                                    Just lvl -> lvl
+                                    Nothing  -> getSlideLevel blks
+                }
+  runPres env def $ blocksToPresentation blks