Remove IORef from EPUB writer.

1 files changed, 62 insertions, 51 deletions

diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs
index 4a93d52e2..8e283a66a 100644
--- a/src/Text/Pandoc/Writers/EPUB.hs
+++ b/src/Text/Pandoc/Writers/EPUB.hs
@@ -29,7 +29,6 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 Conversion of 'Pandoc' documents to EPUB.
 -}
 module Text.Pandoc.Writers.EPUB ( writeEPUB, writeEPUBPure ) where
-import Data.IORef ( IORef )
 import qualified Data.Map as M
 import qualified Data.Set as Set
 import Data.Maybe ( fromMaybe, catMaybes )
@@ -54,7 +53,7 @@ import Text.Pandoc.Options ( WriterOptions(..)
                            , ObfuscationMethod(NoObfuscation) )
 import Text.Pandoc.Definition
 import Text.Pandoc.Walk (walk, walkM, query)
-import Control.Monad.State (modify, get, State, put, evalState)
+import Control.Monad.State (modify, get, gets, State, StateT, put, evalState, evalStateT, lift)
 import Control.Monad (mplus, when)
 import Text.XML.Light ( unode, Element(..), unqual, Attr(..), add_attrs
                       , strContent, lookupAttr, Node(..), QName(..), parseXML
@@ -75,6 +74,11 @@ type EPUBAction = PandocAction [(FilePath, (FilePath, Maybe Entry))]
 -- in filenames, chapter0003.xhtml.
 data Chapter = Chapter (Maybe [Int]) [Block]
 
+data EPUBState = EPUBState { stMediaPaths :: [(FilePath, (FilePath, Maybe Entry))]
+                           }
+
+type E = StateT EPUBState EPUBAction                 
+
 data EPUBMetadata = EPUBMetadata{
     epubIdentifier         :: [Identifier]
   , epubTitle              :: [Title]
@@ -142,7 +146,7 @@ removeNote :: Inline -> Inline
 removeNote (Note _) = Str ""
 removeNote x        = x
 
-getEPUBMetadata :: WriterOptions -> Meta -> EPUBAction EPUBMetadata
+getEPUBMetadata :: WriterOptions -> Meta -> E EPUBMetadata
 getEPUBMetadata opts meta = do
   let md = metadataFromMeta opts meta
   let elts = onlyElems $ parseXML $ writerEpubMetadata opts
@@ -150,7 +154,7 @@ getEPUBMetadata opts meta = do
   let addIdentifier m =
        if null (epubIdentifier m)
           then do
-            randomId <- fmap show P.newUUID
+            randomId <- fmap show (lift P.newUUID)
             return $ m{ epubIdentifier = [Identifier randomId Nothing] }
           else return m
   let addLanguage m =
@@ -158,7 +162,7 @@ getEPUBMetadata opts meta = do
           then case lookup "lang" (writerVariables opts) of
                      Just x  -> return m{ epubLanguage = x }
                      Nothing -> do
-                       mLang <- P.lookupEnv "LANG"
+                       mLang <- lift $ P.lookupEnv "LANG"
                        let localeLang =
                              case mLang of
                                Just lang ->
@@ -170,7 +174,7 @@ getEPUBMetadata opts meta = do
   let fixDate m =
        if null (epubDate m)
           then do
-            currentTime <- P.getCurrentTime
+            currentTime <- lift P.getCurrentTime
             return $ m{ epubDate = [ Date{
                              dateText = showDateTimeISO8601 currentTime
                            , dateEvent = Nothing } ] }
@@ -338,12 +342,21 @@ writeEPUB :: WriterOptions  -- ^ Writer options
 writeEPUB opts doc = runIO $ writeEPUBPure opts doc
 
 writeEPUBPure :: WriterOptions  -- ^ Writer options
-              -> Pandoc         -- ^ Document to convert
-              -> EPUBAction B.ByteString
-writeEPUBPure opts doc@(Pandoc meta _) = do
+          -> Pandoc         -- ^ Document to convert
+          -> EPUBAction B.ByteString
+writeEPUBPure opts doc =
+  let initState = EPUBState { stMediaPaths = []
+                            }
+  in
+    evalStateT (pandocToEPUB opts doc) initState
+
+pandocToEPUB :: WriterOptions  
+              -> Pandoc        
+              -> E B.ByteString
+pandocToEPUB opts doc@(Pandoc meta _) = do
   let version = fromMaybe EPUB2 (writerEpubVersion opts)
   let epub3 = version == EPUB3
-  epochtime <- floor <$> P.getPOSIXTime
+  epochtime <- floor <$> lift P.getPOSIXTime
   let mkEntry path content = toEntry path epochtime content
   let vars = ("epub3", if epub3 then "true" else "false")
            : ("css", "stylesheet.css")
@@ -368,7 +381,7 @@ writeEPUBPure opts doc@(Pandoc meta _) = do
                        let cpContent = renderHtml $ writeHtml
                             opts'{ writerVariables = ("coverpage","true"):vars }
                             (Pandoc meta [RawBlock (Format "html") $ "<div id=\"cover-image\">\n<img src=\"" ++ coverImage ++ "\" alt=\"cover image\" />\n</div>"])
-                       imgContent <- P.readFileLazy img
+                       imgContent <- lift $ P.readFileLazy img
                        return ( [mkEntry "cover.xhtml" cpContent]
                               , [mkEntry coverImage imgContent] )
 
@@ -379,18 +392,17 @@ writeEPUBPure opts doc@(Pandoc meta _) = do
   let tpEntry = mkEntry "title_page.xhtml" tpContent
 
   -- handle pictures
-  mediaRef <- P.newIORef []
-  Pandoc _ blocks <- walkM (transformInline opts' mediaRef) doc >>=
-                     walkM (transformBlock opts' mediaRef)
-  picEntries <- (catMaybes . map (snd . snd)) <$> P.readIORef mediaRef
-
+  -- mediaRef <- P.newIORef []
+  Pandoc _ blocks <- walkM (transformInline opts') doc >>=
+                     walkM (transformBlock opts')
+  picEntries <- (catMaybes . map (snd . snd)) <$> (gets stMediaPaths)
   -- handle fonts
   let matchingGlob f = do
-        xs <- P.namesMatching f
+        xs <- lift $ P.namesMatching f
         when (null xs) $
-          P.warn $ f ++ " did not match any font files."
+          lift $ P.warn $ f ++ " did not match any font files."
         return xs
-  let mkFontEntry f = mkEntry (takeFileName f) `fmap` P.readFileLazy f
+  let mkFontEntry f = mkEntry (takeFileName f) `fmap` (lift $ P.readFileLazy f)
   fontFiles <- concat <$> mapM matchingGlob (writerEpubFonts opts')
   fontEntries <- mapM mkFontEntry fontFiles
 
@@ -527,7 +539,7 @@ writeEPUBPure opts doc@(Pandoc meta _) = do
   let uuid = case epubIdentifier metadata of
                   (x:_) -> identifierText x  -- use first identifier as UUID
                   []    -> error "epubIdentifier is null"  -- shouldn't happen
-  currentTime <- P.getCurrentTime
+  currentTime <- lift $ P.getCurrentTime
   let contentsData = UTF8.fromStringLazy $ ppTopElement $
         unode "package" ! [("version", case version of
                                              EPUB2 -> "2.0"
@@ -699,10 +711,10 @@ writeEPUBPure opts doc@(Pandoc meta _) = do
 
   -- stylesheet
   stylesheet <- case epubStylesheet metadata of
-                   Just (StylesheetPath fp)    -> P.readFileUTF8 fp
+                   Just (StylesheetPath fp)    -> lift $ P.readFileUTF8 fp
                    Just (StylesheetContents s) -> return s
                    Nothing -> UTF8.toString `fmap`
-                              P.readDataFile (writerUserDataDir opts) "epub.css"
+                              (lift $ P.readDataFile (writerUserDataDir opts) "epub.css")
   let stylesheetEntry = mkEntry "stylesheet.css" $ UTF8.fromStringLazy stylesheet
 
   -- construct archive
@@ -819,78 +831,77 @@ showDateTimeISO8601 :: UTCTime -> String
 showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ"
 
 transformTag :: WriterOptions
-             -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media
+             -- -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media
              -> Tag String
-             -> EPUBAction (Tag String)
-transformTag opts mediaRef tag@(TagOpen name attr)
+             -> E (Tag String)
+transformTag opts tag@(TagOpen name attr)
   | name `elem` ["video", "source", "img", "audio"] &&
     lookup "data-external" attr == Nothing = do
   let src = fromAttrib "src" tag
   let poster = fromAttrib "poster" tag
-  newsrc <- modifyMediaRef opts mediaRef src
-  newposter <- modifyMediaRef opts mediaRef poster
+  newsrc <- modifyMediaRef opts src
+  newposter <- modifyMediaRef opts poster
   let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++
               [("src", newsrc) | not (null newsrc)] ++
               [("poster", newposter) | not (null newposter)]
   return $ TagOpen name attr'
-transformTag _ _ tag = return tag
+transformTag _ tag = return tag
 
 modifyMediaRef :: WriterOptions
-               -> IORef [(FilePath, (FilePath, Maybe Entry))]
                -> FilePath
-               -> EPUBAction FilePath
-modifyMediaRef _ _ "" = return ""
-modifyMediaRef opts mediaRef oldsrc = do
-  media <- P.readIORef mediaRef
+               -> E FilePath
+modifyMediaRef _ "" = return ""
+modifyMediaRef opts oldsrc = do
+  media <- gets stMediaPaths
   case lookup oldsrc media of
          Just (n,_) -> return n
          Nothing    -> do
-           res <- P.fetchItem' (writerMediaBag opts)
+           res <- lift $ P.fetchItem' (writerMediaBag opts)
                     (writerSourceURL opts) oldsrc
            (new, mbEntry) <-
                 case res of
                       Left _        -> do
-                        P.warn $ "Could not find media `" ++ oldsrc ++ "', skipping..."
+                        lift $ P.warn $ "Could not find media `" ++ oldsrc ++ "', skipping..."
                         return (oldsrc, Nothing)
                       Right (img,mbMime) -> do
                         let new = "media/file" ++ show (length media) ++
                                fromMaybe (takeExtension (takeWhile (/='?') oldsrc))
                                  (('.':) <$> (mbMime >>= extensionFromMimeType))
-                        epochtime <- floor `fmap` P.getPOSIXTime
+                        epochtime <- floor `fmap` lift P.getPOSIXTime
                         let entry = toEntry new epochtime $ B.fromChunks . (:[]) $ img
                         return (new, Just entry)
-           P.modifyIORef mediaRef ( (oldsrc, (new, mbEntry)): )
+           modify $ \st -> st{ stMediaPaths = (oldsrc, (new, mbEntry)):media}
            return new
 
 transformBlock  :: WriterOptions
-                -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media
+                -- -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media
                 -> Block
-                -> EPUBAction Block
-transformBlock opts mediaRef (RawBlock fmt raw)
+                -> E Block
+transformBlock opts (RawBlock fmt raw)
   | fmt == Format "html" = do
   let tags = parseTags raw
-  tags' <- mapM (transformTag opts mediaRef)  tags
+  tags' <- mapM (transformTag opts)  tags
   return $ RawBlock fmt (renderTags' tags')
-transformBlock _ _ b = return b
+transformBlock _ b = return b
 
 transformInline  :: WriterOptions
-                 -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath) media
+                 -- -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath) media
                  -> Inline
-                 -> EPUBAction Inline
-transformInline opts mediaRef (Image attr lab (src,tit)) = do
-    newsrc <- modifyMediaRef opts mediaRef src
+                 -> E Inline
+transformInline opts (Image attr lab (src,tit)) = do
+    newsrc <- modifyMediaRef opts src
     return $ Image attr lab (newsrc, tit)
-transformInline opts mediaRef (x@(Math t m))
+transformInline opts (x@(Math t m))
   | WebTeX url <- writerHTMLMathMethod opts = do
-    newsrc <- modifyMediaRef opts mediaRef (url ++ urlEncode m)
+    newsrc <- modifyMediaRef opts (url ++ urlEncode m)
     let mathclass = if t == DisplayMath then "display" else "inline"
     return $ Span ("",["math",mathclass],[]) [Image nullAttr [x] (newsrc, "")]
-transformInline opts mediaRef  (RawInline fmt raw)
+transformInline opts (RawInline fmt raw)
   | fmt == Format "html" = do
   let tags = parseTags raw
-  tags' <- mapM (transformTag opts mediaRef) tags
+  tags' <- mapM (transformTag opts) tags
   return $ RawInline fmt (renderTags' tags')
-transformInline _ _ x = return x
+transformInline _ x = return x
 
 (!) :: (t -> Element) -> [(String, String)] -> t -> Element
 (!) f attrs n = add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) (f n)