aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc/Writers/EPUB.hs113
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)