Add Powerpoint writer.

This imports the essential Powerpoint writer.

It works following the standard Pandoc conventions for making other
sorts of slides. At the moment, there are still these TODOs:

1. Syntax highlighting is not yet implemented. (This is difficult
   because there are no character classes in Powerpoint.)

2. Footnotes and Definition lists are not yet implemented. (Notes will
   usually take the form of a final slide.

3. Image placement and auto-resizing has a few glitches.

4. Reference powerpoint files don't work dependably from the command
   line. This will be implemented, but at the moment users are advised
   to change themes from within Powerpoint.

1 files changed, 1665 insertions, 0 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs
new file mode 100644
index 000000000..f7d5bbc5f
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Powerpoint.hs
@@ -0,0 +1,1665 @@
+{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}
+
+{-
+Copyright (C) 2017 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
+   Copyright   : Copyright (C) 2017 Jesse Rosenthal
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
+   Stability   : alpha
+   Portability : portable
+
+Conversion of 'Pandoc' documents to powerpoint (pptx).
+-}
+
+module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where
+
+import Control.Monad.Except (throwError)
+import Control.Monad.Reader
+import Control.Monad.State
+import Codec.Archive.Zip
+import Data.List (intercalate, stripPrefix, isPrefixOf, nub)
+-- import Control.Monad (mplus)
+import Data.Default
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+import System.FilePath.Posix (splitDirectories, splitExtension)
+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 Text.Pandoc.Logging
+import qualified Data.ByteString.Lazy as BL
+-- import qualified Data.ByteString.Lazy.Char8 as BL8
+-- import qualified Text.Pandoc.UTF8 as UTF8
+import Text.Pandoc.Walk
+import Text.Pandoc.Writers.Shared (fixDisplayMath)
+import Text.Pandoc.Writers.OOXML
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, listToMaybe)
+import Text.Pandoc.ImageSize
+import Control.Applicative ((<|>))
+
+import Text.TeXMath
+import Text.Pandoc.Writers.Math (convertMath)
+
+
+writePowerpoint :: (PandocMonad m)
+                => WriterOptions  -- ^ Writer options
+                -> Pandoc         -- ^ Document to convert
+                -> 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
+
+  let env = def { envMetadata = meta
+                , envRefArchive = refArchive
+                , envDistArchive = distArchive
+                , envUTCTime = utctime
+                , envOpts = opts
+                }
+  runP env def $ 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 :: PresentationSize
+                           , envSlideHasHeader :: Bool
+                           , envInList :: Bool
+                           }
+                 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 = def
+                  , envSlideHasHeader = False
+                  , envInList = False
+                  }
+
+data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
+                           , mInfoLocalId  :: Int
+                           , mInfoGlobalId :: Int
+                           , mInfoMimeType :: Maybe MimeType
+                           , mInfoExt      :: Maybe String
+                           , mInfoCaption  :: Bool
+                           } deriving (Show, Eq)
+
+data WriterState = WriterState { stCurSlideId :: Int
+                               -- the difference between the number at
+                               -- the end of the slide file name and
+                               -- the rId number
+                               , stSlideIdOffset :: Int
+                               , 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
+                               } deriving (Show, Eq)
+
+instance Default WriterState where
+  def = WriterState { stCurSlideId = 0
+                    , stSlideIdOffset = 1
+                    , stLinkIds = mempty
+                    , stMediaIds = mempty
+                    , stMediaGlobalIds = mempty
+                    }
+
+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 PresentationSize [Slide]
+  deriving (Show)
+
+data PresentationSize = PresentationSize { presSizeWidth :: Pixels
+                                         , presSizeRatio :: PresentationRatio
+                                         }
+                      deriving (Show, Eq)
+
+data PresentationRatio = Ratio4x3
+                       | Ratio16x9
+                       | Ratio16x10
+                       deriving (Show, Eq)
+
+-- Note that right now we're only using Ratio4x3.
+getPageHeight :: PresentationSize -> Pixels
+getPageHeight sz = case presSizeRatio sz of
+  Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double)
+  Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double)
+  Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double)  
+
+instance Default PresentationSize where
+  def = PresentationSize 720 Ratio4x3
+
+data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
+                            , metadataSlideSubtitle :: [ParaElem]
+                            , metadataSlideAuthors :: [[ParaElem]]
+                            , metadataSlideDate :: [ParaElem]
+                            } 
+           | TitleSlide { titleSlideHeader :: [ParaElem]}
+           | ContentSlide { contentSlideHeader :: [ParaElem]
+                          , contentSlideContent :: [Shape]
+                          }
+           deriving (Show, Eq)
+
+data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape
+  deriving (Show, Eq)
+
+data Shape = Pic 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)
+
+data HeaderType = TitleHeader | SlideHeader | InternalHeader Int
+                deriving (Show, Eq)
+
+-- type StartingAt = Int 
+
+-- data AutoNumType = ArabicNum
+--                  | AlphaUpperNum
+--                  | AlphaLowerNum
+--                  | RomanUpperNum
+--                  | RomanLowerNum
+--                  deriving (Show, Eq)
+
+-- data AutoNumDelim = PeriodDelim
+--                   | OneParenDelim
+--                   | TwoParensDelim
+--                   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 { pPropHeaderType :: Maybe HeaderType
+                           , pPropMarginLeft :: Maybe Pixels
+                           , pPropMarginRight :: Maybe Pixels
+                           , pPropLevel :: Int
+                           , pPropBullet :: Maybe BulletType
+                           , pPropAlign :: Maybe Algnment
+                           } deriving (Show, Eq)
+
+instance Default ParaProps where
+  def = ParaProps { pPropHeaderType = Nothing
+                  , pPropMarginLeft = Just 0
+                  , pPropMarginRight = Just 0
+                  , pPropLevel = 0
+                  , pPropBullet = Nothing
+                  , pPropAlign = 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
+                         } 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
+                 }
+
+--------------------------------------------------
+
+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 = def{rPropCode = True}}) $
+    inlineToParElems $ Str str
+inlineToParElems (Math mathtype str) =
+  return [MathElem mathtype (TeXString str)]
+inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils
+inlineToParElems (RawInline _ _) = return []
+inlineToParElems _ = return []
+
+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]
+-- TODO: work out the format
+blockToParagraphs (BlockQuote blks) =
+  local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
+                , envRunProps = (envRunProps r){rPropBlockQuote = True}})$
+  concatMapM blockToParagraphs blks
+-- TODO: work out the format
+blockToParagraphs (RawBlock _ _) = return []
+  -- parElems <- inlinesToParElems [Str str]
+  -- paraProps <- asks envParaProps  
+  -- return [Paragraph paraProps parElems]
+-- TODO: work out the format  
+blockToParagraphs (Header n _ ils) = do
+  slideLevel <- asks envSlideLevel
+  parElems <- inlinesToParElems ils
+  -- For the time being we're not doing headers inside of bullets, but
+  -- we might change that.
+  let headerType = case n `compare` slideLevel of
+                     LT -> TitleHeader
+                     EQ -> SlideHeader
+                     GT -> InternalHeader (n - slideLevel)
+  return [Paragraph def{pPropHeaderType = Just headerType} 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 (Div _ blks)  = concatMapM blockToParagraphs blks
+-- TODO
+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 url attr <$> (inlinesToParElems ils)
+blockToShape (Para (il:_))  | Image attr ils (url, _) <- il =
+      Pic url attr <$> (inlinesToParElems ils)
+blockToShape (Table caption algn _ hdrCells rows) = do
+  caption' <- inlinesToParElems caption
+  pageWidth <- presSizeWidth <$> 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
+
+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
+splitBlocks' cur acc ((Para (img@(Image _ _ _):ils)) : blks) = do
+  slideLevel <- asks envSlideLevel  
+  case cur of
+    (Header n _ _) : [] | n == slideLevel ->
+                            splitBlocks' []
+                            (acc ++ [cur ++ [Para [img]]])
+                            (if null ils then blks else (Para ils) : blks)
+    _ ->  splitBlocks' []
+          (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]])
+          (if null ils then blks else (Para ils) : blks)
+splitBlocks' cur acc ((Plain (img@(Image _ _ _):ils)) : blks) = do
+  slideLevel <- asks envSlideLevel  
+  case cur of
+    (Header n _ _) : [] | n == slideLevel ->
+                            splitBlocks' []
+                            (acc ++ [cur ++ [Para [img]]])
+                            (if null ils then blks else (Plain ils) : blks)
+    _ ->  splitBlocks' []
+          (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]])
+          (if null ils then blks else (Plain 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 (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 _ ils) : blks)
+  | n < lvl = do
+      hdr <- inlinesToParElems ils
+      return $ TitleSlide {titleSlideHeader = hdr}
+  | n == lvl = do
+      hdr <- inlinesToParElems ils
+      shapes <- blocksToShapes blks
+      return $ ContentSlide { contentSlideHeader = hdr
+                            , contentSlideContent = shapes
+                            }
+blocksToSlide' _ (blk : blks) = do
+      shapes <- 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
+
+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
+                                       }
+
+blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation
+blocksToPresentation blks = do
+  blksLst <- splitBlocks blks
+  slides <- mapM blocksToSlide blksLst
+  metadataslide <- getMetaSlide
+  presSize <- asks envPresentationSize
+  return $ case metadataslide of
+             Just metadataslide' -> Presentation presSize $ metadataslide' : slides
+             Nothing            -> Presentation presSize slides
+
+--------------------------------------------------------------------
+
+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
+
+getMediaFiles :: PandocMonad m => P m [FilePath]
+getMediaFiles = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
+  return $ filter (isPrefixOf "ppt/media") allEntries
+  
+
+copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
+copyFileToArchiveIfExists arch fp = do
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
+    Nothing -> return $ arch
+    Just e -> return $ addEntryToArchive e arch
+
+inheritedFiles :: [FilePath]
+inheritedFiles = [ "_rels/.rels"
+                 , "docProps/app.xml"
+                 , "docProps/core.xml"
+                 , "ppt/slideLayouts/slideLayout4.xml"
+                 , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
+                 , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
+                 , "ppt/slideLayouts/slideLayout2.xml"
+                 , "ppt/slideLayouts/slideLayout8.xml"
+                 , "ppt/slideLayouts/slideLayout11.xml"
+                 , "ppt/slideLayouts/slideLayout3.xml"
+                 , "ppt/slideLayouts/slideLayout6.xml"
+                 , "ppt/slideLayouts/slideLayout9.xml"
+                 , "ppt/slideLayouts/slideLayout5.xml"
+                 , "ppt/slideLayouts/slideLayout7.xml"
+                 , "ppt/slideLayouts/slideLayout1.xml"
+                 , "ppt/slideLayouts/slideLayout10.xml"
+                 -- , "ppt/_rels/presentation.xml.rels"
+                 , "ppt/theme/theme1.xml"
+                 , "ppt/presProps.xml"
+                 -- , "ppt/slides/_rels/slide1.xml.rels"
+                 -- , "ppt/slides/_rels/slide2.xml.rels"
+                 -- This is the one we're
+                 -- going to build
+                 -- , "ppt/slides/slide2.xml" 
+                 -- , "ppt/slides/slide1.xml"
+                 , "ppt/viewProps.xml"
+                 , "ppt/tableStyles.xml"
+                 , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
+                 , "ppt/slideMasters/slideMaster1.xml"
+                 -- , "ppt/presentation.xml"
+                 -- , "[Content_Types].xml"
+                 ]
+
+-- Here are some that might not be there. We won't fail if they're not
+possibleInheritedFiles :: [FilePath]
+possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
+
+presentationToArchive :: PandocMonad m => Presentation -> P m Archive
+presentationToArchive p@(Presentation _ slides) = do
+  newArch <- foldM copyFileToArchive emptyArchive inheritedFiles
+  mediaDir <- getMediaFiles
+  newArch' <- foldM copyFileToArchiveIfExists newArch $
+              possibleInheritedFiles ++ mediaDir
+  -- 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 (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss)
+  | pPropHeaderType (paraProps p) == Just TitleHeader ||
+    pPropHeaderType (paraProps p) == Just SlideHeader =
+      TextBox [p] : (combineShapes $ TextBox ps : s' : ss)
+  | pPropHeaderType (paraProps p') == Just TitleHeader ||
+    pPropHeaderType (paraProps p') == Just SlideHeader =
+      s : TextBox [p'] : (combineShapes $ TextBox ps' : ss)
+  | otherwise = 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"
+  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
+  -- let ns = elemToNameSpaces root
+  -- case findChild (elemName ns "p" "cSld") root of
+  --   Just element' -> return element'
+  --   Nothing       -> throwError $
+  --                    PandocSomeError $
+  --                    layoutpath ++ " not correctly formed layout file"
+
+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
+
+-- getContentTitleShape :: NameSpaces -> Element -> Maybe Element
+-- getContentTitleShape ns spTreeElem
+--   | isElem ns "p" "spTree" spTreeElem = 
+--   filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Title 1" e)) spTreeElem
+--   | otherwise = Nothing
+
+-- getSubtitleShape :: NameSpaces -> Element -> Maybe Element
+-- getSubtitleShape ns spTreeElem
+--   | isElem ns "p" "spTree" spTreeElem = 
+--   filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Subtitle 2" e)) spTreeElem
+--   | otherwise = Nothing
+
+-- getDateShape :: NameSpaces -> Element -> Maybe Element
+-- getDateShape ns spTreeElem
+--   | isElem ns "p" "spTree" spTreeElem = 
+--   filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Date Placeholder 3" e)) spTreeElem
+--   | otherwise = Nothing
+  
+getContentShape :: NameSpaces -> Element -> Maybe Element
+getContentShape ns spTreeElem
+  | isElem ns "p" "spTree" spTreeElem = 
+  filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem
+  | otherwise = Nothing
+
+
+-- cursorHasName :: QName -> XMLC.Cursor -> Bool
+-- cursorHasName nm cur = case XMLC.current cur of
+--   Elem element -> case XMLC.tagName $ XMLC.getTag element of
+--                        nm -> True
+--                        _ -> False
+--   _ -> False
+
+-- fillInTxBody :: NameSpaces -> [Paragraph] -> Element -> Element
+-- fillInTxBody ns paras txBodyElem
+--   | isElem ns "p" "txBody" txBodyElem =
+--       replaceNamedChildren ns "a" "p" (map paragraphToElement paras) txBodyElem
+--   | otherwise = txBodyElem
+
+-- fillInShape :: NameSpaces -> Shape -> Element -> Element
+-- fillInShape ns shape spElem
+--   | TextBox paras <- shape
+--   , isElemn ns "p" "sp" spElem =
+--       replaceNamedChildren ns "p" "txBody" (fillInTxBody ns paras sp
+
+
+-- fillInShape :: NameSpaces -> Element -> Shape -> Element
+-- fillInShape ns spElem (TextBox paras) = fillInParagraphs ns spElem paras
+-- fillInShape _ spElem pic = spElem
+
+contentIsElem :: NameSpaces -> String -> String -> Content -> Bool
+contentIsElem ns prefix name (Elem element) = isElem ns prefix name element
+contentIsElem _ _ _ _ = False
+
+replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element
+replaceNamedChildren ns prefix name newKids element =
+  let content = elContent element
+      content' = filter (\c -> not (contentIsElem ns prefix name c)) content
+  in
+    element{elContent = content' ++ map Elem newKids}
+
+
+----------------------------------------------------------------
+
+registerLink :: PandocMonad m => (URL, String) -> P m Int
+registerLink link = do
+  curSlideId <- gets stCurSlideId
+  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 <- gets stCurSlideId
+  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))
+
+createCaption :: PandocMonad m => [ParaElem] -> P m Element
+createCaption paraElements = do
+  let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements
+  elements <- mapM paragraphToElement [para]
+  let ((x, y), (cx, cy)) = captionPosition  
+  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 x), ("y", show y)] ()
+                         , mknode "a:ext" [("cx", show cx), ("cy", show cy)] ()
+                         ]
+                       , mknode "a:prstGeom" [("prst", "rect")]
+                         [ mknode "a:avLst" [] ()
+                         ]
+                       , mknode "a:noFill" [] ()
+                       ]
+                     , txBody
+                     ]
+
+-- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily
+-- abstracted because of some different namespaces and monads. TODO.
+makePicElement :: PandocMonad m
+               => MediaInfo
+               -> Text.Pandoc.Definition.Attr
+               -> P m Element
+makePicElement mInfo attr = do
+  opts <- asks envOpts
+  pageWidth <- presSizeWidth <$> asks envPresentationSize
+  pageHeight <- getPageHeight <$> asks envPresentationSize
+  hasHeader <- asks envSlideHasHeader
+  let hasCaption = mInfoCaption mInfo
+  (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
+  -- We're not using x exts
+  ((hXoff, hYoff), (_, hYext)) <- if hasHeader
+                                  then getHeaderSize
+                                  else return ((0, 0), (0, 0))
+
+  let ((capX, capY), (_, _)) = if hasCaption
+                               then captionPosition
+                               else ((0,0), (0,0))
+  let (xpt,ypt) = desiredSizeInPoints opts attr
+                  (either (const def) id (imageSize opts imgBytes))
+  -- 12700 emu = 1 pt
+  let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700)
+                    ((pageWidth * 12700) - (2 * hXoff) - (2 * capX))
+                    ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext))
+      (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700)
+      xoff' = if hasHeader then xoff + hXoff else xoff
+      xoff'' = if hasCaption then xoff' + capX else xoff'
+      yoff' = if hasHeader then hYoff + hYext else yoff
+      -- let (xemu,yemu)=((floor $ xpt * 12700), (floor $ ypt * 12700))
+  let cNvPicPr = mknode "p:cNvPicPr" [] $
+                 mknode "a:picLocks" [("noGrp","1")
+                                     ,("noChangeAspect","1")] ()
+  let nvPicPr  = mknode "p:nvPicPr" []
+                 [ mknode "p:cNvPr"
+                   [("descr", mInfoFilePath mInfo),("id","0"),("name","Picture 1")] ()
+                 , 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 xemu)
+                                 ,("cy",show yemu)] () ]
+  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]
+  return $
+    mknode "p:pic" []
+      [ nvPicPr
+      , blipFill
+      , spPr ]
+
+-- Currently hardcoded, until I figure out how to make it dynamic.    
+blockQuoteSize :: Pixels
+blockQuoteSize = 20
+
+paraElemToElement :: PandocMonad m => ParaElem -> P m Element
+paraElemToElement Break = return $ mknode "a:br" [] ()
+paraElemToElement (Run rpr s) = do
+  let attrs =
+        if rPropCode rpr
+        then []
+        else (if rPropBlockQuote rpr then [("sz", (show $ blockQuoteSize * 100))] 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
+                                 return [mknode "a:hlinkClick"
+                                          [("r:id", "rId" ++ show idNum)]
+                                          ()
+                                        ]
+                 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 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
+  , Just sp <- getContentShape ns spTree = do
+      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
+  -- XXX: TODO
+  | otherwise = return $ mknode "p:sp" [] ()
+-- XXX: TODO
+shapeToElement layout (Pic fp attr alt) = do
+  mInfo <- registerMedia fp alt
+  case mInfoExt mInfo of
+    Just _ -> makePicElement mInfo attr
+    Nothing -> shapeToElement layout $ TextBox [Paragraph def alt]
+shapeToElement _ (GraphicFrame tbls _) = do
+  elements <- mapM graphicToElement tbls
+  return $ 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", "457200"), ("y", "1600200")] ()
+      , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] ()
+      ]
+    ] ++ elements
+
+shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
+shapeToElements layout shp = do
+  case shp of
+    (Pic _ _ alt) | (not . null) alt -> do
+      element <- shapeToElement layout shp
+      caption <- createCaption alt
+      return [element, caption]
+    (GraphicFrame _ cptn) | (not . null) cptn -> do
+      element <- shapeToElement layout shp
+      caption <- createCaption cptn
+      return [element, caption]
+    _ -> 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
+   
+
+graphicToElement :: PandocMonad m => Graphic -> P m Element
+graphicToElement (Tbl tblPr colWidths hdrCells rows) = do
+  let cellToOpenXML paras = do elements <- mapM paragraphToElement paras
+                               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 textwidth = 14400  -- 5.5 in in twips, 1/20 pt
+  -- let fullrow = 14400 -- 100% specified in pct
+  -- let rowwidth = fullrow * sum colWidths
+
+  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
+
+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" [] ()
+
+
+-- hdrToElement :: Element -> [ParaElem] -> Element
+-- hdrToElement layout paraElems
+--   | ns <- elemToNameSpaces layout
+--   , Just cSld <- findChild (elemName ns "p" "cSld") layout
+--   , Just spTree <- findChild (elemName ns "p" "spTree") cSld
+--   , Just sp <- getContentTitleShape ns spTree = 
+--   let hdrPara = Paragraph def paraElems
+--       txBody = mknode "p:txBody" [] $
+--                [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
+--                [paragraphToElement hdrPara]
+--   in
+--     replaceNamedChildren ns "p" "txBody" [txBody] sp
+--   -- XXX: TODO
+--   | otherwise = mknode "p:sp" [] ()
+-- -- XXX: TODO
+-- hdrToElement _ _ = 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 <- shapesToElements layout shapes
+      return $
+        replaceNamedChildren ns "p" "sp"
+        (hdrShapeElements ++ contentElements)
+        spTree
+contentToElement _ _ _ = 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@(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 <- gets stSlideIdOffset
+  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 <- gets stSlideIdOffset 
+  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
+  modify $ \st -> st{stCurSlideId = idNum}
+  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 :: Int -> (URL, String) -> Element
+linkRelElement idNum (url, _) =
+  mknode "Relationship" [ ("Id", "rId" ++ show idNum)
+                        , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
+                        , ("Target", url)
+                        , ("TargetMode", "External")
+                        ] ()
+
+linkRelElements :: M.Map Int (URL, String) -> [Element]
+linkRelElements mp = map (\(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"
+
+  linkIds <- gets stLinkIds
+  mediaIds <- gets stMediaIds
+
+  let linkRels = case M.lookup idNum linkIds of
+                   Just mp -> linkRelElements mp
+                   Nothing -> []
+      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)
+
+-- slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
+-- slideToSlideRelEntry slide idNum = do
+--   let fp = "ppt/slides/_rels/slide" ++ (show idNum) ++ ".xml.rels"
+--   elemToEntry fp $ slideToSlideRelElement slide
+
+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)
+
+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
+  let defaults = [ DefaultContentType "xml" "application/xml"
+                 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
+                 ]
+      mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos
+      inheritedOverrides = mapMaybe pathToOverride inheritedFiles
+      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)
+
+-- slideToElement :: Element -> Slide -> Element
+-- slideToElement layout (ContentSlide _ shapes) =
+--   let sps = map (shapeToElement layout) shapes
+
+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" : f : [] <- splitDirectories fp
+  -- , (_, ".xml") <- splitExtension f =
+  | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=
+      Just $ presML ++ ".slideLayout+xml"
+  | otherwise = Nothing