Moved fillMedia, extractMedia from App to Class.

Also generalized type of fillMedia to any instance of PandocMonad.

2 files changed, 56 insertions, 52 deletions

diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs
index a1691c5e2..6bc345d73 100644
--- a/src/Text/Pandoc/App.hs
+++ b/src/Text/Pandoc/App.hs
@@ -39,14 +39,13 @@ module Text.Pandoc.App (
           ) where
 import Control.Applicative ((<|>))
 import qualified Control.Exception as E
-import Control.Monad.Except (catchError, throwError)
+import Control.Monad.Except (throwError)
 import Control.Monad
 import Control.Monad.Trans
 import Data.Aeson (eitherDecode', encode)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as B
 import Data.Char (toLower, toUpper)
-import Data.Digest.Pure.SHA (sha1, showDigest)
 import qualified Data.Set as Set
 import Data.Foldable (foldrM)
 import Data.List (intercalate, isPrefixOf, isSuffixOf, sort)
@@ -70,19 +69,16 @@ import System.IO (stdout)
 import System.IO.Error (isDoesNotExistError)
 import Text.Pandoc
 import Text.Pandoc.Builder (setMeta)
-import Text.Pandoc.Class (PandocIO, getLog, withMediaBag, getMediaBag,
-                          fetchItem, insertMedia, report)
+import Text.Pandoc.Class (PandocIO, getLog, withMediaBag,
+                          extractMedia, fillMedia)
 import Text.Pandoc.Highlighting (highlightingStyles)
 import Text.Pandoc.Lua ( runLuaFilter )
-import Text.Pandoc.MediaBag (extractMediaBag, mediaDirectory)
-import Text.Pandoc.MIME (extensionFromMimeType)
 import Text.Pandoc.PDF (makePDF)
 import Text.Pandoc.Process (pipeProcess)
 import Text.Pandoc.SelfContained (makeSelfContained, makeDataURI)
 import Text.Pandoc.Shared (headerShift, openURL, readDataFile,
                            readDataFileUTF8, safeRead, tabFilter)
 import qualified Text.Pandoc.UTF8 as UTF8
-import Text.Pandoc.Walk (walkM, walk)
 import Text.Pandoc.XML (toEntities)
 import Text.Printf
 #ifndef _WINDOWS
@@ -731,48 +727,6 @@ defaultWriterName x =
 
 -- Transformations of a Pandoc document post-parsing:
 
--- | Traverse tree, filling media bag.
-fillMedia :: Maybe String -> Pandoc -> PandocIO Pandoc
-fillMedia sourceURL d = walkM handleImage d
-  where handleImage :: Inline -> PandocIO Inline
-        handleImage (Image attr lab (src, tit)) = catchError
-          (do (bs, mt) <- fetchItem sourceURL src
-              let ext = fromMaybe (takeExtension src)
-                          (mt >>= extensionFromMimeType)
-              let bs' = B.fromChunks [bs]
-              let basename = showDigest $ sha1 bs'
-              let fname = basename <.> ext
-              insertMedia fname mt bs'
-              return $ Image attr lab (fname, tit))
-          (\e -> do
-              case e of
-                PandocResourceNotFound _ -> do
-                  report $ CouldNotFetchResource src
-                            "replacing image with description"
-                  -- emit alt text
-                  return $ Span ("",["image"],[]) lab
-                PandocHttpError u er -> do
-                  report $ CouldNotFetchResource u
-                            (show er ++ "\rReplacing image with description.")
-                  -- emit alt text
-                  return $ Span ("",["image"],[]) lab
-                _ -> throwError e)
-        handleImage x = return x
-
-extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
-extractMedia dir d = do
-  media <- getMediaBag
-  case [fp | (fp, _, _) <- mediaDirectory media] of
-        []  -> return d
-        fps -> do
-          liftIO $ extractMediaBag True dir media
-          return $ walk (adjustImagePath dir fps) d
-
-adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
-adjustImagePath dir paths (Image attr lab (src, tit))
-   | src `elem` paths = Image attr lab (dir ++ "/" ++ src, tit)
-adjustImagePath _ _ x = x
-
 applyTransforms :: Monad m => [Transform] -> Pandoc -> m Pandoc
 applyTransforms transforms d = return $ foldr ($) d transforms
 
diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs
index 939e0bd18..7407d0799 100644
--- a/src/Text/Pandoc/Class.hs
+++ b/src/Text/Pandoc/Class.hs
@@ -61,6 +61,8 @@ module Text.Pandoc.Class ( PandocMonad(..)
                          , runIOorExplode
                          , runPure
                          , withMediaBag
+                         , fillMedia
+                         , extractMedia
                          ) where
 
 import Prelude hiding (readFile)
@@ -76,8 +78,11 @@ import Text.Pandoc.Compat.Time (UTCTime)
 import Text.Pandoc.Logging
 import Text.Parsec (ParsecT)
 import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
-import Text.Pandoc.MIME (MimeType, getMimeType)
+import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType)
+import Text.Pandoc.Definition
 import Data.Char (toLower)
+import Data.Digest.Pure.SHA (sha1, showDigest)
+import Data.Maybe (fromMaybe)
 import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds
                              , posixSecondsToUTCTime
                              , POSIXTime )
@@ -86,13 +91,15 @@ import Network.URI ( escapeURIString, nonStrictRelativeTo,
                      unEscapeString, parseURIReference, isAllowedInURI,
                      parseURI, URI(..) )
 import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
-import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
+import Text.Pandoc.MediaBag (MediaBag, lookupMedia, extractMediaBag,
+                             mediaDirectory)
+import Text.Pandoc.Walk (walkM, walk)
 import qualified Text.Pandoc.MediaBag as MB
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified System.Environment as IO (lookupEnv)
 import System.FilePath.Glob (match, compile)
-import System.FilePath ((</>), takeExtension, dropExtension, isRelative)
+import System.FilePath ((</>), (<.>), takeExtension, dropExtension, isRelative)
 import qualified System.FilePath.Glob as IO (glob)
 import qualified System.Directory as IO (getModificationTime)
 import Control.Monad as M (fail)
@@ -338,6 +345,49 @@ withPaths (p:ps) action fp =
   catchError (action (p </> fp))
              (\_ -> withPaths ps action fp)
 
+-- | Traverse tree, filling media bag.
+fillMedia :: PandocMonad m => Maybe String -> Pandoc -> m Pandoc
+fillMedia sourceURL d = walkM handleImage d
+  where handleImage :: PandocMonad m => Inline -> m Inline
+        handleImage (Image attr lab (src, tit)) = catchError
+          (do (bs, mt) <- fetchItem sourceURL src
+              let ext = fromMaybe (takeExtension src)
+                          (mt >>= extensionFromMimeType)
+              let bs' = BL.fromChunks [bs]
+              let basename = showDigest $ sha1 bs'
+              let fname = basename <.> ext
+              insertMedia fname mt bs'
+              return $ Image attr lab (fname, tit))
+          (\e -> do
+              case e of
+                PandocResourceNotFound _ -> do
+                  report $ CouldNotFetchResource src
+                            "replacing image with description"
+                  -- emit alt text
+                  return $ Span ("",["image"],[]) lab
+                PandocHttpError u er -> do
+                  report $ CouldNotFetchResource u
+                            (show er ++ "\rReplacing image with description.")
+                  -- emit alt text
+                  return $ Span ("",["image"],[]) lab
+                _ -> throwError e)
+        handleImage x = return x
+
+-- | Extract media from the mediabag into a directory.
+extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
+extractMedia dir d = do
+  media <- getMediaBag
+  case [fp | (fp, _, _) <- mediaDirectory media] of
+        []  -> return d
+        fps -> do
+          liftIO $ extractMediaBag True dir media
+          return $ walk (adjustImagePath dir fps) d
+
+adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
+adjustImagePath dir paths (Image attr lab (src, tit))
+   | src `elem` paths = Image attr lab (dir ++ "/" ++ src, tit)
+adjustImagePath _ _ x = x
+
 data PureState = PureState { stStdGen     :: StdGen
                            , stWord8Store :: [Word8] -- should be
                                                      -- inifinite,