Powerpoint writer: read presentation size from reference file.

Our presentation size is now dependent on the reference/template file
we use. This will make it easier to set different output sizes by
supplying different reference files. The alternative (allowing a user
to explicitly set output size regardless of the template) will lead to
too many thorny issues, as explicitly set sizes at the various level
of powerpoint layout would have to be reset.

1 files changed, 45 insertions, 29 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs
index 86f07d9c6..17ffe611c 100644
--- a/src/Text/Pandoc/Writers/Powerpoint.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint.hs
@@ -82,6 +82,12 @@ writePowerpoint opts (Pandoc meta blks) = do
 
   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
@@ -90,6 +96,7 @@ writePowerpoint opts (Pandoc meta blks) = do
                 , envSlideLevel = case writerSlideLevel opts of
                                     Just n -> n
                                     Nothing -> getSlideLevel blks'
+                , envPresentationSize = presSize
                 }
 
   let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
@@ -110,7 +117,7 @@ data WriterEnv = WriterEnv { envMetadata :: Meta
                            , envDistArchive :: Archive
                            , envUTCTime :: UTCTime
                            , envOpts :: WriterOptions
-                           , envPresentationSize :: PresentationSize
+                           , envPresentationSize :: (Integer, Integer)
                            , envSlideHasHeader :: Bool
                            , envInList :: Bool
                            , envInNoteSlide :: Bool
@@ -131,7 +138,7 @@ instance Default WriterEnv where
                   , envDistArchive = emptyArchive
                   , envUTCTime = posixSecondsToUTCTime 0
                   , envOpts = def
-                  , envPresentationSize = def
+                  , envPresentationSize = (720, 540)
                   , envSlideHasHeader = False
                   , envInList = False
                   , envInNoteSlide = False
@@ -183,6 +190,19 @@ initialGlobalIds refArchive distArchive =
   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
@@ -190,28 +210,28 @@ runP env st p = evalStateT (runReaderT p env) st
 
 type Pixels = Integer
 
-data Presentation = Presentation PresentationSize [Slide]
+data Presentation = Presentation [Slide]
   deriving (Show)
 
-data PresentationSize = PresentationSize { presSizeWidth :: Pixels
-                                         , presSizeRatio :: PresentationRatio
-                                         }
-                      deriving (Show, Eq)
+-- data PresentationSize = PresentationSize { presSizeWidth :: Pixels
+--                                          , presSizeRatio :: PresentationRatio
+--                                          }
+--                       deriving (Show, Eq)
 
-data PresentationRatio = Ratio4x3
-                       | Ratio16x9
-                       | Ratio16x10
-                       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)
+-- 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
+-- instance Default PresentationSize where
+--   def = PresentationSize 720 Ratio4x3
 
 data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
                             , metadataSlideSubtitle :: [ParaElem]
@@ -520,7 +540,7 @@ blockToShape (Para (il:_))  | Link _ (il':_) target <- il
       Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
 blockToShape (Table caption algn _ hdrCells rows) = do
   caption' <- inlinesToParElems caption
-  pageWidth <- presSizeWidth <$> asks envPresentationSize
+  (pageWidth, _) <- asks envPresentationSize
   hdrCells' <- rowToParagraphs algn hdrCells
   rows' <- mapM (rowToParagraphs algn) rows
   let tblPr = if null hdrCells
@@ -641,8 +661,6 @@ blocksToSlide blks = do
   slideLevel <- asks envSlideLevel
   blocksToSlide' slideLevel blks
 
-
-
 makeNoteEntry :: Int -> [Block] -> [Block]
 makeNoteEntry n blks =
   let enum = Str (show n ++ ".")
@@ -763,9 +781,8 @@ blocksToPresentation blks = do
                                         })
                            (blocksToSlide $ notesSlideBlocks)
                          return [notesSlide]
-  presSize <- asks envPresentationSize
   return $
-    Presentation presSize $
+    Presentation $
     metadataslides ++ tocSlides ++ bodyslides ++ notesSlides
 
 --------------------------------------------------------------------
@@ -829,7 +846,7 @@ requiredFiles = [ "_rels/.rels"
 
 
 presentationToArchive :: PandocMonad m => Presentation -> P m Archive
-presentationToArchive p@(Presentation _ slides) = do
+presentationToArchive p@(Presentation slides) = do
   filePaths <- patternsToFilePaths inheritedPatterns
 
   -- make sure all required files are available:
@@ -1126,8 +1143,7 @@ makePicElement :: PandocMonad m
                -> P m Element
 makePicElement picProps mInfo attr = do
   opts <- asks envOpts
-  pageWidth <- presSizeWidth <$> asks envPresentationSize
-  pageHeight <- getPageHeight <$> asks envPresentationSize
+  (pageWidth, pageHeight) <- asks envPresentationSize
   hasHeader <- asks envSlideHasHeader
   let hasCaption = mInfoCaption mInfo
   (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
@@ -1621,7 +1637,7 @@ getRels = do
   return $ mapMaybe elementToRel relElems
 
 presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
-presentationToRels (Presentation _ slides) = do
+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
@@ -1749,7 +1765,7 @@ slideToSldIdElement slide idNum = do
   return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
 
 presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
-presentationToSldIdLst (Presentation _ slides) = do
+presentationToSldIdLst (Presentation slides) = do
   ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
   return $ mknode "p:sldIdLst" [] ids
 
@@ -1845,7 +1861,7 @@ mediaContentType mInfo
   | otherwise = Nothing
 
 presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
-presentationToContentTypes (Presentation _ slides) = do
+presentationToContentTypes (Presentation slides) = do
   mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
   filePaths <- patternsToFilePaths inheritedPatterns
   let mediaFps = filter (match (compile "ppt/media/image*")) filePaths