diff options
author | Jesse Rosenthal <jrosenthal@jhu.edu> | 2016-09-24 17:52:25 -0400 |
---|---|---|
committer | John MacFarlane <jgm@berkeley.edu> | 2017-01-25 17:07:39 +0100 |
commit | 32c68dada92eb142949c5be5224a3ddf20fcf484 (patch) | |
tree | 41ba1aaf202d0f6093218ab1ceadaf3b159c5a83 /src/Text | |
parent | 0ab4af2f03f4226714a39c959c161def679d9d57 (diff) | |
download | pandoc-32c68dada92eb142949c5be5224a3ddf20fcf484.tar.gz |
Introduce pure versions of IO Writers.
Using Text.Pandoc.Free, introduce pure versions of Docx, EPUB, ICML, and
ODT writers. Each of the pure versions is exported along with the IO
version (produced by running `runIO` on the pure reader). Ideally, this
should make the writers easier to test.
Diffstat (limited to 'src/Text')
-rw-r--r-- | src/Text/Pandoc/Writers/Docx.hs | 66 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/EPUB.hs | 81 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/ICML.hs | 19 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/ODT.hs | 48 |
4 files changed, 124 insertions, 90 deletions
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index d425bbbca..cecee7e9e 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, PatternGuards, ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables, PatternGuards, ViewPatterns, DeriveFunctor #-} {- Copyright (C) 2012-2015 John MacFarlane <jgm@berkeley.edu> @@ -28,7 +28,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to docx. -} -module Text.Pandoc.Writers.Docx ( writeDocx ) where +module Text.Pandoc.Writers.Docx ( writeDocx, writeDocxPure ) where import Data.List ( intercalate, isPrefixOf, isSuffixOf ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -38,7 +38,6 @@ import qualified Data.Set as Set import qualified Text.Pandoc.UTF8 as UTF8 import Codec.Archive.Zip import Data.Time.Clock.POSIX -import System.Environment import Text.Pandoc.Compat.Time import Text.Pandoc.Definition import Text.Pandoc.Generic @@ -57,7 +56,7 @@ import Control.Monad.Reader import Control.Monad.State import Skylighting import Data.Unique (hashUnique, newUnique) -import System.Random (randomRIO) +import System.Random (randomR) import Text.Printf (printf) import qualified Control.Exception as E import Data.Monoid ((<>)) @@ -67,6 +66,10 @@ import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef, import Control.Applicative ((<|>)) import Data.Maybe (fromMaybe, mapMaybe, maybeToList, isNothing) import Data.Char (ord, isSpace, toLower) +import Text.Pandoc.Free (PandocAction, runIO) +import qualified Text.Pandoc.Free as P + +type DocxAction = PandocAction () data ListMarker = NoMarker | BulletMarker @@ -146,7 +149,7 @@ defaultWriterState = WriterState{ , stDynamicTextProps = [] } -type WS = ReaderT WriterEnv (StateT WriterState IO) +type WS = ReaderT WriterEnv (StateT WriterState (DocxAction)) mknode :: Node t => String -> [(String,String)] -> t -> Element mknode s attrs = @@ -213,19 +216,27 @@ metaValueToInlines (MetaBlocks bs) = query return bs metaValueToInlines (MetaBool b) = [Str $ show b] metaValueToInlines _ = [] --- | Produce an Docx file from a Pandoc document. + + writeDocx :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO BL.ByteString -writeDocx opts doc@(Pandoc meta _) = do +writeDocx opts doc = runIO $ writeDocxPure opts doc + + +-- | Produce an Docx file from a Pandoc document. +writeDocxPure :: WriterOptions -- ^ Writer options + -> Pandoc -- ^ Document to convert + -> DocxAction BL.ByteString +writeDocxPure opts doc@(Pandoc meta _) = do let datadir = writerUserDataDir opts let doc' = walk fixDisplayMath $ doc - username <- lookup "USERNAME" <$> getEnvironment - utctime <- getCurrentTime - distArchive <- getDefaultReferenceDocx datadir + username <- P.lookupEnv "USERNAME" + utctime <- P.getCurrentTime + distArchive <- P.getDefaultReferenceDocx datadir refArchive <- case writerReferenceDocx opts of - Just f -> liftM (toArchive . toLazy) $ B.readFile f - Nothing -> getDefaultReferenceDocx datadir + Just f -> liftM (toArchive . toLazy) $ P.readFileStrict f + Nothing -> P.getDefaultReferenceDocx datadir parsedDoc <- parseXml refArchive distArchive "word/document.xml" let wname f qn = qPrefix qn == Just "w" && f (qName qn) @@ -603,7 +614,7 @@ styleToOpenXml sm style = $ backgroundColor style ) ] -copyChildren :: Archive -> Archive -> String -> Integer -> [String] -> IO Entry +copyChildren :: Archive -> Archive -> String -> Integer -> [String] -> DocxAction Entry copyChildren refArchive distArchive path timestamp elNames = do ref <- parseXml refArchive distArchive path dist <- parseXml distArchive distArchive path @@ -622,7 +633,7 @@ copyChildren refArchive distArchive path timestamp elNames = do baseListId :: Int baseListId = 1000 -mkNumbering :: [ListMarker] -> IO [Element] +mkNumbering :: [ListMarker] -> DocxAction [Element] mkNumbering lists = do elts <- mapM mkAbstractNum (ordNub lists) return $ elts ++ zipWith mkNum lists [baseListId..(baseListId + length lists - 1)] @@ -638,9 +649,10 @@ mkNum marker numid = map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",show (lvl :: Int))] $ mknode "w:startOverride" [("w:val",show start)] ()) [0..6] -mkAbstractNum :: ListMarker -> IO Element +mkAbstractNum :: ListMarker -> DocxAction Element mkAbstractNum marker = do - nsid <- randomRIO (0x10000000 :: Integer, 0xFFFFFFFF :: Integer) + gen <- P.newStdGen + let (nsid, _) = randomR (0x10000000 :: Integer, 0xFFFFFFFF :: Integer) gen return $ mknode "w:abstractNum" [("w:abstractNumId",listMarkerToId marker)] $ mknode "w:nsid" [("w:val", printf "%8x" nsid)] () : mknode "w:multiLevelType" [("w:val","multilevel")] () @@ -695,6 +707,7 @@ mkLvl marker lvl = getNumId :: WS Int getNumId = (((baseListId - 1) +) . length) `fmap` gets stLists + makeTOC :: WriterOptions -> WS [Element] makeTOC opts | writerTableOfContents opts = do let depth = "1-"++(show (writerTOCDepth opts)) @@ -781,10 +794,10 @@ rStyleM styleName = do let sty' = getStyleId styleName $ sCharStyleMap styleMaps return $ mknode "w:rStyle" [("w:val",sty')] () -getUniqueId :: MonadIO m => m String +getUniqueId :: DocxAction String -- the + 20 is to ensure that there are no clashes with the rIds -- already in word/document.xml.rel -getUniqueId = liftIO $ (show . (+ 20) . hashUnique) `fmap` newUnique +getUniqueId = (show . (+ 20) . hashUnique) <$> P.newUnique -- | Key for specifying user-defined docx styles. dynamicStyleKey :: String @@ -825,7 +838,7 @@ blockToOpenXML' opts (Header lev (ident,_,_) lst) = do then uniqueIdent lst usedIdents else ident modify $ \s -> s{ stSectionIds = Set.insert bookmarkName $ stSectionIds s } - id' <- getUniqueId + id' <- (lift . lift) getUniqueId let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') ,("w:name",bookmarkName)] () let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () @@ -1137,7 +1150,7 @@ inlineToOpenXML' opts (Code attrs str) = do else unhighlighted inlineToOpenXML' opts (Note bs) = do notes <- gets stFootnotes - notenum <- getUniqueId + notenum <- (lift . lift) getUniqueId footnoteStyle <- rStyleM "Footnote Reference" let notemarker = mknode "w:r" [] [ mknode "w:rPr" [] footnoteStyle @@ -1168,7 +1181,7 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do id' <- case M.lookup src extlinks of Just i -> return i Nothing -> do - i <- ("rId"++) `fmap` getUniqueId + i <- ("rId"++) `fmap` ((lift . lift) getUniqueId) modify $ \st -> st{ stExternalLinks = M.insert src i extlinks } return i @@ -1180,15 +1193,14 @@ inlineToOpenXML' opts (Image attr alt (src, title)) = do case M.lookup src imgs of Just (_,_,_,elt,_) -> return [elt] Nothing -> do - res <- liftIO $ - fetchItem' (writerMediaBag opts) (writerSourceURL opts) src + res <- (lift . lift) $ P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src case res of Left (_ :: E.SomeException) -> do - warn $ "Could not find image `" ++ src ++ "', skipping..." + (lift . lift) $ P.warn ("Could not find image `" ++ src ++ "', skipping...") -- emit alt text inlinesToOpenXML opts alt Right (img, mt) -> do - ident <- ("rId"++) `fmap` getUniqueId + ident <- ("rId"++) `fmap` ((lift . lift) getUniqueId) let (xpt,ypt) = desiredSizeInPoints opts attr (either (const def) id (imageSize img)) -- 12700 emu = 1 pt @@ -1272,13 +1284,13 @@ defaultFootnotes = [ mknode "w:footnote" [ mknode "w:r" [] $ [ mknode "w:continuationSeparator" [] ()]]]] -parseXml :: Archive -> Archive -> String -> IO Element +parseXml :: Archive -> Archive -> String -> DocxAction Element parseXml refArchive distArchive relpath = case findEntryByPath relpath refArchive `mplus` findEntryByPath relpath distArchive of Nothing -> fail $ relpath ++ " missing in reference docx" Just e -> case parseXMLDoc . UTF8.toStringLazy . fromEntry $ e of - Nothing -> fail $ relpath ++ " corrupt in reference docx" + Nothing -> P.fail $ relpath ++ " corrupt in reference docx" Just d -> return d -- | Scales the image to fit the page diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 00bf4a81c..4a93d52e2 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -28,26 +28,23 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to EPUB. -} -module Text.Pandoc.Writers.EPUB ( writeEPUB ) where -import Data.IORef ( IORef, newIORef, readIORef, modifyIORef ) +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 ) import Data.List ( isPrefixOf, isInfixOf, intercalate ) -import System.Environment ( getEnv ) import Text.Printf (printf) import System.FilePath ( takeExtension, takeFileName ) -import System.FilePath.Glob ( namesMatching ) import Network.HTTP ( urlEncode ) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as B8 import qualified Text.Pandoc.UTF8 as UTF8 import Codec.Archive.Zip ( emptyArchive, addEntryToArchive, eRelativePath, fromEntry , Entry, toEntry, fromArchive) -import Data.Time.Clock.POSIX ( getPOSIXTime ) import Text.Pandoc.Compat.Time import Text.Pandoc.Shared ( renderTags', safeRead, uniqueIdent, trim - , normalizeDate, readDataFile, stringify, warn - , hierarchicalize, fetchItem' ) + , normalizeDate, stringify + , hierarchicalize ) import qualified Text.Pandoc.Shared as S (Element(..)) import Text.Pandoc.Builder (fromList, setMeta) import Text.Pandoc.Options ( WriterOptions(..) @@ -58,17 +55,19 @@ import Text.Pandoc.Options ( WriterOptions(..) import Text.Pandoc.Definition import Text.Pandoc.Walk (walk, walkM, query) import Control.Monad.State (modify, get, State, put, evalState) -import Control.Monad (mplus, liftM, when) +import Control.Monad (mplus, when) import Text.XML.Light ( unode, Element(..), unqual, Attr(..), add_attrs , strContent, lookupAttr, Node(..), QName(..), parseXML , onlyElems, node, ppElement) -import Text.Pandoc.UUID (getRandomUUID) import Text.Pandoc.Writers.HTML ( writeHtml ) import Data.Char ( toLower, isDigit, isAlphaNum ) import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType) -import qualified Control.Exception as E import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.HTML.TagSoup (Tag(TagOpen), fromAttrib, parseTags) +import Text.Pandoc.Free (PandocAction, runIO) +import qualified Text.Pandoc.Free as P + +type EPUBAction = PandocAction [(FilePath, (FilePath, Maybe Entry))] -- A Chapter includes a list of blocks and maybe a section -- number offset. Note, some chapters are unnumbered. The section @@ -143,7 +142,7 @@ removeNote :: Inline -> Inline removeNote (Note _) = Str "" removeNote x = x -getEPUBMetadata :: WriterOptions -> Meta -> IO EPUBMetadata +getEPUBMetadata :: WriterOptions -> Meta -> EPUBAction EPUBMetadata getEPUBMetadata opts meta = do let md = metadataFromMeta opts meta let elts = onlyElems $ parseXML $ writerEpubMetadata opts @@ -151,7 +150,7 @@ getEPUBMetadata opts meta = do let addIdentifier m = if null (epubIdentifier m) then do - randomId <- fmap show getRandomUUID + randomId <- fmap show P.newUUID return $ m{ epubIdentifier = [Identifier randomId Nothing] } else return m let addLanguage m = @@ -159,16 +158,19 @@ getEPUBMetadata opts meta = do then case lookup "lang" (writerVariables opts) of Just x -> return m{ epubLanguage = x } Nothing -> do - localeLang <- E.catch (liftM - (map (\c -> if c == '_' then '-' else c) . - takeWhile (/='.')) $ getEnv "LANG") - (\e -> let _ = (e :: E.SomeException) in return "en-US") + mLang <- P.lookupEnv "LANG" + let localeLang = + case mLang of + Just lang -> + map (\c -> if c == '_' then '-' else c) $ + takeWhile (/='.') lang + Nothing -> "en-US" return m{ epubLanguage = localeLang } else return m let fixDate m = if null (epubDate m) then do - currentTime <- getCurrentTime + currentTime <- P.getCurrentTime return $ m{ epubDate = [ Date{ dateText = showDateTimeISO8601 currentTime , dateEvent = Nothing } ] } @@ -333,10 +335,15 @@ metadataFromMeta opts meta = EPUBMetadata{ writeEPUB :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO B.ByteString -writeEPUB opts doc@(Pandoc meta _) = do +writeEPUB opts doc = runIO $ writeEPUBPure opts doc + +writeEPUBPure :: WriterOptions -- ^ Writer options + -> Pandoc -- ^ Document to convert + -> EPUBAction B.ByteString +writeEPUBPure opts doc@(Pandoc meta _) = do let version = fromMaybe EPUB2 (writerEpubVersion opts) let epub3 = version == EPUB3 - epochtime <- floor `fmap` getPOSIXTime + epochtime <- floor <$> P.getPOSIXTime let mkEntry path content = toEntry path epochtime content let vars = ("epub3", if epub3 then "true" else "false") : ("css", "stylesheet.css") @@ -361,7 +368,7 @@ writeEPUB 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 <- B.readFile img + imgContent <- P.readFileLazy img return ( [mkEntry "cover.xhtml" cpContent] , [mkEntry coverImage imgContent] ) @@ -372,18 +379,18 @@ writeEPUB opts doc@(Pandoc meta _) = do let tpEntry = mkEntry "title_page.xhtml" tpContent -- handle pictures - mediaRef <- newIORef [] + mediaRef <- P.newIORef [] Pandoc _ blocks <- walkM (transformInline opts' mediaRef) doc >>= walkM (transformBlock opts' mediaRef) - picEntries <- (catMaybes . map (snd . snd)) <$> readIORef mediaRef + picEntries <- (catMaybes . map (snd . snd)) <$> P.readIORef mediaRef -- handle fonts let matchingGlob f = do - xs <- namesMatching f + xs <- P.namesMatching f when (null xs) $ - warn $ f ++ " did not match any font files." + P.warn $ f ++ " did not match any font files." return xs - let mkFontEntry f = mkEntry (takeFileName f) `fmap` B.readFile f + let mkFontEntry f = mkEntry (takeFileName f) `fmap` P.readFileLazy f fontFiles <- concat <$> mapM matchingGlob (writerEpubFonts opts') fontEntries <- mapM mkFontEntry fontFiles @@ -520,7 +527,7 @@ writeEPUB 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 <- getCurrentTime + currentTime <- P.getCurrentTime let contentsData = UTF8.fromStringLazy $ ppTopElement $ unode "package" ! [("version", case version of EPUB2 -> "2.0" @@ -692,10 +699,10 @@ writeEPUB opts doc@(Pandoc meta _) = do -- stylesheet stylesheet <- case epubStylesheet metadata of - Just (StylesheetPath fp) -> UTF8.readFile fp + Just (StylesheetPath fp) -> P.readFileUTF8 fp Just (StylesheetContents s) -> return s Nothing -> UTF8.toString `fmap` - readDataFile (writerUserDataDir opts) "epub.css" + P.readDataFile (writerUserDataDir opts) "epub.css" let stylesheetEntry = mkEntry "stylesheet.css" $ UTF8.fromStringLazy stylesheet -- construct archive @@ -814,7 +821,7 @@ showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ" transformTag :: WriterOptions -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media -> Tag String - -> IO (Tag String) + -> EPUBAction (Tag String) transformTag opts mediaRef tag@(TagOpen name attr) | name `elem` ["video", "source", "img", "audio"] && lookup "data-external" attr == Nothing = do @@ -831,34 +838,34 @@ transformTag _ _ tag = return tag modifyMediaRef :: WriterOptions -> IORef [(FilePath, (FilePath, Maybe Entry))] -> FilePath - -> IO FilePath + -> EPUBAction FilePath modifyMediaRef _ _ "" = return "" modifyMediaRef opts mediaRef oldsrc = do - media <- readIORef mediaRef + media <- P.readIORef mediaRef case lookup oldsrc media of Just (n,_) -> return n Nothing -> do - res <- fetchItem' (writerMediaBag opts) + res <- P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) oldsrc (new, mbEntry) <- case res of Left _ -> do - warn $ "Could not find media `" ++ oldsrc ++ "', skipping..." + 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` getPOSIXTime + epochtime <- floor `fmap` P.getPOSIXTime let entry = toEntry new epochtime $ B.fromChunks . (:[]) $ img return (new, Just entry) - modifyIORef mediaRef ( (oldsrc, (new, mbEntry)): ) + P.modifyIORef mediaRef ( (oldsrc, (new, mbEntry)): ) return new transformBlock :: WriterOptions -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath, entry) media -> Block - -> IO Block + -> EPUBAction Block transformBlock opts mediaRef (RawBlock fmt raw) | fmt == Format "html" = do let tags = parseTags raw @@ -869,7 +876,7 @@ transformBlock _ _ b = return b transformInline :: WriterOptions -> IORef [(FilePath, (FilePath, Maybe Entry))] -- ^ (oldpath, newpath) media -> Inline - -> IO Inline + -> EPUBAction Inline transformInline opts mediaRef (Image attr lab (src,tit)) = do newsrc <- modifyMediaRef opts mediaRef src return $ Image attr lab (newsrc, tit) diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index e2c123fc2..3a1e772ce 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -18,7 +18,7 @@ import Text.Pandoc.Definition import Text.Pandoc.XML import Text.Pandoc.Readers.TeXMath (texMathToInlines) import Text.Pandoc.Writers.Shared -import Text.Pandoc.Shared (linesToPara, splitBy, fetchItem, warn) +import Text.Pandoc.Shared (linesToPara, splitBy, warn) import Text.Pandoc.Options import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Pretty @@ -28,6 +28,10 @@ import Data.Text as Text (breakOnAll, pack) import Control.Monad.State import Network.URI (isURI) import qualified Data.Set as Set +import Text.Pandoc.Free (runIO) +import qualified Text.Pandoc.Free as P + +type ICMLAction = P.PandocAction () type Style = [String] type Hyperlink = [(Int, String)] @@ -40,7 +44,7 @@ data WriterState = WriterState{ , maxListDepth :: Int } -type WS a = StateT WriterState IO a +type WS a = StateT WriterState ICMLAction a defaultWriterState :: WriterState defaultWriterState = WriterState{ @@ -121,10 +125,13 @@ subListParName = "subParagraph" footnoteName = "Footnote" citeName = "Cite" - -- | Convert Pandoc document to string in ICML format. writeICML :: WriterOptions -> Pandoc -> IO String -writeICML opts (Pandoc meta blocks) = do +writeICML opts doc = runIO $ writeICMLPure opts doc + +-- | Convert Pandoc document to string in ICML format. +writeICMLPure :: WriterOptions -> Pandoc -> ICMLAction String +writeICMLPure opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing @@ -532,10 +539,10 @@ styleToStrAttr style = -- | Assemble an ICML Image. imageICML :: WriterOptions -> Style -> Attr -> Target -> WS Doc imageICML opts style attr (src, _) = do - res <- liftIO $ fetchItem (writerSourceURL opts) src + res <- lift $ P.fetchItem (writerSourceURL opts) src imgS <- case res of Left (_) -> do - warn $ "Could not find image `" ++ src ++ "', skipping..." + lift $ P.warn $ "Could not find image `" ++ src ++ "', skipping..." return def Right (img, _) -> do case imageSize img of diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index ce4d456a3..0f1dd7cd3 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -28,7 +28,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to ODT. -} -module Text.Pandoc.Writers.ODT ( writeODT ) where +module Text.Pandoc.Writers.ODT ( writeODTPure, writeODT ) where import Data.IORef import Data.List ( isPrefixOf ) import Data.Maybe ( fromMaybe ) @@ -38,8 +38,7 @@ import qualified Data.ByteString.Lazy as B import Text.Pandoc.UTF8 ( fromStringLazy ) import Codec.Archive.Zip import Text.Pandoc.Options ( WriterOptions(..), WrapOption(..) ) -import Text.Pandoc.Shared ( stringify, fetchItem', warn, - getDefaultReferenceODT ) +import Text.Pandoc.Shared ( stringify ) import Text.Pandoc.ImageSize import Text.Pandoc.MIME ( getMimeType, extensionFromMimeType ) import Text.Pandoc.Definition @@ -50,28 +49,37 @@ import Control.Monad (liftM) import Text.Pandoc.XML import Text.Pandoc.Pretty import qualified Control.Exception as E -import Data.Time.Clock.POSIX ( getPOSIXTime ) import System.FilePath ( takeExtension, takeDirectory, (<.>)) +import Text.Pandoc.Free ( PandocAction, runIO ) +import qualified Text.Pandoc.Free as P + +type ODTAction = PandocAction [Entry] -- | Produce an ODT file from a Pandoc document. writeODT :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO B.ByteString -writeODT opts doc@(Pandoc meta _) = do +writeODT opts doc = runIO $ writeODTPure opts doc + +-- | Produce an ODT file from a Pandoc document. +writeODTPure :: WriterOptions -- ^ Writer options + -> Pandoc -- ^ Document to convert + -> ODTAction B.ByteString +writeODTPure opts doc@(Pandoc meta _) = do let datadir = writerUserDataDir opts let title = docTitle meta refArchive <- case writerReferenceODT opts of - Just f -> liftM toArchive $ B.readFile f - Nothing -> getDefaultReferenceODT datadir + Just f -> liftM toArchive $ P.readFileLazy f + Nothing -> P.getDefaultReferenceODT datadir -- handle formulas and pictures - picEntriesRef <- newIORef ([] :: [Entry]) + picEntriesRef <- P.newIORef ([] :: [Entry]) doc' <- walkM (transformPicMath opts picEntriesRef) $ walk fixDisplayMath doc let newContents = writeOpenDocument opts{writerWrapText = WrapNone} doc' - epochtime <- floor `fmap` getPOSIXTime + epochtime <- floor `fmap` P.getPOSIXTime let contentEntry = toEntry "content.xml" epochtime $ fromStringLazy newContents - picEntries <- readIORef picEntriesRef + picEntries <- P.readIORef picEntriesRef let archive = foldr addEntryToArchive refArchive $ contentEntry : picEntries -- construct META-INF/manifest.xml based on archive @@ -126,18 +134,18 @@ writeODT opts doc@(Pandoc meta _) = do return $ fromArchive archive'' -- | transform both Image and Math elements -transformPicMath :: WriterOptions -> IORef [Entry] -> Inline -> IO Inline +transformPicMath :: WriterOptions -> IORef [Entry] -> Inline -> ODTAction Inline transformPicMath opts entriesRef (Image attr@(id', cls, _) lab (src,t)) = do - res <- fetchItem' (writerMediaBag opts) (writerSourceURL opts) src + res <- P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src case res of Left (_ :: E.SomeException) -> do - warn $ "Could not find image `" ++ src ++ "', skipping..." + P.warn $ "Could not find image `" ++ src ++ "', skipping..." return $ Emph lab Right (img, mbMimeType) -> do (ptX, ptY) <- case imageSize img of Right s -> return $ sizeInPoints s Left msg -> do - warn $ "Could not determine image size in `" ++ + P.warn $ "Could not determine image size in `" ++ src ++ "': " ++ msg return (100, 100) let dims = @@ -155,28 +163,28 @@ transformPicMath opts entriesRef (Image attr@(id', cls, _) lab (src,t)) = do Just dim -> Just $ Inch $ inInch opts dim Nothing -> Nothing let newattr = (id', cls, dims) - entries <- readIORef entriesRef + entries <- P.readIORef entriesRef let extension = fromMaybe (takeExtension $ takeWhile (/='?') src) (mbMimeType >>= extensionFromMimeType) let newsrc = "Pictures/" ++ show (length entries) <.> extension let toLazy = B.fromChunks . (:[]) - epochtime <- floor `fmap` getPOSIXTime + epochtime <- floor `fmap` P.getPOSIXTime let entry = toEntry newsrc epochtime $ toLazy img - modifyIORef entriesRef (entry:) + P.modifyIORef entriesRef (entry:) return $ Image newattr lab (newsrc, t) transformPicMath _ entriesRef (Math t math) = do - entries <- readIORef entriesRef + entries <- P.readIORef entriesRef let dt = if t == InlineMath then DisplayInline else DisplayBlock case writeMathML dt <$> readTeX math of Left _ -> return $ Math t math Right r -> do let conf = useShortEmptyTags (const False) defaultConfigPP let mathml = ppcTopElement conf r - epochtime <- floor `fmap` getPOSIXTime + epochtime <- floor `fmap` P.getPOSIXTime let dirname = "Formula-" ++ show (length entries) ++ "/" let fname = dirname ++ "content.xml" let entry = toEntry fname epochtime (fromStringLazy mathml) - modifyIORef entriesRef (entry:) + P.modifyIORef entriesRef (entry:) return $ RawInline (Format "opendocument") $ render Nothing $ inTags False "draw:frame" [("text:anchor-type", if t == DisplayMath |