Improvements to docx writer.

Avoid reading image files again when we've already processed them.

1 files changed, 63 insertions, 65 deletions

diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index 5d220ca79..f40429aaa 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -59,7 +59,7 @@ data WriterState = WriterState{
        , stFootnotes      :: [Element]
        , stSectionIds     :: [String]
        , stExternalLinks  :: M.Map String String
-       , stImages         :: M.Map FilePath (String, B.ByteString)
+       , stImages         :: M.Map FilePath (String, String, Element, B.ByteString)
        , stListLevel      :: Int
        , stListNumId      :: Int
        , stNumStyles      :: M.Map ListMarker Int
@@ -112,13 +112,7 @@ writeDocx opts doc@(Pandoc (Meta tit auths date) _) = do
                        defaultWriterState
   epochtime <- floor `fmap` getPOSIXTime
   let imgs = M.elems $ stImages st
-  let imgPath ident img = "media/" ++ ident ++
-                            case imageType img of
-                                  Just Png  -> ".png"
-                                  Just Jpeg -> ".jpeg"
-                                  Just Gif  -> ".gif"
-                                  Nothing   -> ""
-  let toImgRel (ident,img) =  mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",imgPath ident img)] ()
+  let toImgRel (ident,path,_,_) =  mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] ()
   let newrels = map toImgRel imgs
   let relpath = "word/_rels/document.xml.rels"
   let reldoc = case findEntryByPath relpath refArchive >>=
@@ -127,8 +121,7 @@ writeDocx opts doc@(Pandoc (Meta tit auths date) _) = do
                       Nothing -> error $ relpath ++ "missing in reference docx"
   let reldoc' = reldoc{ elContent = elContent reldoc ++ map Elem newrels }
   -- create entries for images
-  let toImageEntry (ident,img) = toEntry ("word/" ++ imgPath ident img)
-         epochtime $ toLazy img
+  let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
   let imageEntries = map toImageEntry imgs
   -- NOW get list of external links and images from this, and do what's needed
   let toLinkRel (src,ident) =  mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] ()
@@ -626,61 +619,66 @@ inlineToOpenXML opts (Link txt (src,_)) = do
               return i
   return [ mknode "w:hyperlink" [("r:id",id')] contents ]
 inlineToOpenXML opts (Image alt (src, tit)) = do
-  res <- liftIO $ E.try $ getItem (writerUserDataDir opts) src
-  -- res is Right (img, maybeMIMEString) or Left err
-  case res of
-     Left (_ :: E.SomeException) -> do
-       liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
-       inlinesToOpenXML opts alt
-     Right (img, _) -> do
-       imgs <- gets stImages
-       -- TODO move this check to before the getItem
-       -- also TODO, instead of storing ident, imagebs; store
-       -- the whole Element, so we don't have to reconstruct it at all.
-       (ident,size) <- case M.lookup src imgs of
-                            Just (i,img') -> return (i, imageSize img')
-                            Nothing -> do
-                              ident' <- ("rId"++) `fmap` getUniqueId
-                              let size'  = imageSize img
-                              modify $ \st -> st{
-                                 stImages = M.insert src (ident',img) $ stImages st }
-                              return (ident',size')
-       let (xpt,ypt) = maybe (120,120) sizeInPoints size
-       -- 12700 emu = 1 pt
-       let (xemu,yemu) = (xpt * 12700, ypt * 12700)
-       let cNvPicPr = mknode "pic:cNvPicPr" [] $
-                        mknode "a:picLocks" [("noChangeArrowheads","1"),("noChangeAspect","1")] ()
-       let nvPicPr  = mknode "pic:nvPicPr" []
-                       [ mknode "pic:cNvPr"
-                           [("descr",src),("id","0"),("name","Picture")] ()
-                       , cNvPicPr ]
-       let blipFill = mknode "pic:blipFill" []
-                        [ mknode "a:blip" [("r:embed",ident)] ()
-                        , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ]
-       let xfrm =    mknode "a:xfrm" []
-                       [ mknode "a:off" [("x","0"),("y","0")] ()
-                       , 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 "pic:spPr" [("bwMode","auto")]
-                       [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
-       let graphic = mknode "a:graphic" [] $
-                       mknode "a:graphicData" [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")]
-                         [ mknode "pic:pic" []
-                           [ nvPicPr
-                           , blipFill
-                           , spPr ] ]
-       return [ mknode "w:r" [] $
-           mknode "w:drawing" [] $
-             mknode "wp:inline" []
-               [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] ()
-               , mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] ()
-               , mknode "wp:docPr" [("descr",tit),("id","1"),("name","Picture")] ()
-               , graphic ] ]
+  -- first, check to see if we've already done this image
+  imgs <- gets stImages
+  case M.lookup src imgs of
+    Just (_,_,elt,_) -> return [elt]
+    Nothing -> do
+      res <- liftIO $ E.try $ getItem (writerUserDataDir opts) src
+      case res of
+        Left (_ :: E.SomeException) -> do
+          liftIO $ warn $ "Could not find image `" ++ src ++ "', skipping..."
+          -- emit alt text
+          inlinesToOpenXML opts alt
+        Right (img, _) -> do
+          ident <- ("rId"++) `fmap` getUniqueId
+          let size = imageSize img
+          let (xpt,ypt) = maybe (120,120) sizeInPoints size
+          -- 12700 emu = 1 pt
+          let (xemu,yemu) = (xpt * 12700, ypt * 12700)
+          let cNvPicPr = mknode "pic:cNvPicPr" [] $
+                           mknode "a:picLocks" [("noChangeArrowheads","1"),("noChangeAspect","1")] ()
+          let nvPicPr  = mknode "pic:nvPicPr" []
+                          [ mknode "pic:cNvPr"
+                              [("descr",src),("id","0"),("name","Picture")] ()
+                          , cNvPicPr ]
+          let blipFill = mknode "pic:blipFill" []
+                           [ mknode "a:blip" [("r:embed",ident)] ()
+                           , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ]
+          let xfrm =    mknode "a:xfrm" []
+                          [ mknode "a:off" [("x","0"),("y","0")] ()
+                          , 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 "pic:spPr" [("bwMode","auto")]
+                          [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
+          let graphic = mknode "a:graphic" [] $
+                          mknode "a:graphicData" [("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")]
+                            [ mknode "pic:pic" []
+                              [ nvPicPr
+                              , blipFill
+                              , spPr ] ]
+          let imgElt = mknode "w:r" [] $
+               mknode "w:drawing" [] $
+                 mknode "wp:inline" []
+                  [ mknode "wp:extent" [("cx",show xemu),("cy",show yemu)] ()
+                  , mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] ()
+                  , mknode "wp:docPr" [("descr",tit),("id","1"),("name","Picture")] ()
+                  , graphic ]
+          modify $ \st -> st{ stImages = M.insert src (ident, imgPath ident img, imgElt, img) $ stImages st }
+          return [imgElt]
+
+imgPath :: String -> B.ByteString -> String
+imgPath ident img = "media/" ++ ident ++
+                            case imageType img of
+                                  Just Png  -> ".png"
+                                  Just Jpeg -> ".jpeg"
+                                  Just Gif  -> ".gif"
+                                  Nothing   -> ""
 
 br :: Element
 br = mknode "w:r" [] [mknode "w:cr" [] () ]