EPUB writer: don't put multiple copies of same image in epub.

1 files changed, 17 insertions, 10 deletions

diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs
index 1ac2c8244..f8d9117f6 100644
--- a/src/Text/Pandoc/Writers/EPUB.hs
+++ b/src/Text/Pandoc/Writers/EPUB.hs
@@ -80,11 +80,14 @@ writeEPUB mbStylesheet opts doc = do
                                ,writerVariables = ("titlepage","yes"):vars} doc
   let tpEntry = toEntry "title_page.xhtml" epochtime tpContent
   -- handle pictures
-  picEntriesRef <- newIORef ([] :: [Entry])
+  picsRef <- newIORef []
   Pandoc meta blocks <- liftM (processWith transformBlock) $
      processWithM (transformInlines (writerHTMLMathMethod opts)
-                     sourceDir picEntriesRef) doc
-  picEntries <- readIORef picEntriesRef
+                     sourceDir picsRef) doc
+  pics <- readIORef picsRef
+  let readPicEntry (oldsrc, newsrc) = readEntry [] oldsrc >>= \e ->
+                                          return e{ eRelativePath = newsrc }
+  picEntries <- mapM readPicEntry pics
   -- body pages
   let isH1 (Header 1 _) = True
       isH1 _            = False
@@ -191,18 +194,22 @@ metadataElement metadataXML uuid lang title authors =
 
 transformInlines :: HTMLMathMethod
                  -> FilePath
-                 -> IORef [Entry]
+                 -> IORef [(FilePath, FilePath)] -- ^ (oldpath, newpath) images
                  -> [Inline]
                  -> IO [Inline]
 transformInlines _ _ _ (Image lab (src,_) : xs) | isNothing (imageTypeOf src) =
   return $ Emph lab : xs
 transformInlines _ sourceDir picsRef (Image lab (src,tit) : xs) = do
-  entries <- readIORef picsRef
-  let newsrc = "images/img" ++ show (length entries) ++ takeExtension src
-  catch (readEntry [] (sourceDir </> src) >>= \entry ->
-           modifyIORef picsRef (entry{ eRelativePath = newsrc } :) >>
-           return (Image lab (newsrc, tit) : xs))
-        (\_ -> return (Emph lab : xs))
+  pics <- readIORef picsRef
+  let oldsrc = sourceDir </> src
+  let ext = takeExtension src
+  newsrc <- case lookup oldsrc pics of
+                  Just n  -> return n
+                  Nothing -> do
+                        let new = "images/img" ++ show (length pics) ++ ext
+                        modifyIORef picsRef ( (oldsrc, new): )
+                        return new
+  return $ Image lab (newsrc, tit) : xs
 transformInlines (MathML _) _ _ (x@(Math _ _) : xs) = do
   let writeHtmlInline opts z = removeTrailingSpace $
          writeHtmlString opts $ Pandoc (Meta [] [] []) [Plain [z]]