From 2710fc426130738715fdf1ac6dd0c111a5ac8340 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Sat, 3 Dec 2016 17:10:50 +0100 Subject: Class: Renamed 'warn' to 'addWarning' and consolidated RTF writer. * Renaming Text.Pandoc.Class.warn to addWarning avoids conflict with Text.Pandoc.Shared.warn. * Removed writeRTFWithEmbeddedImages from Text.Pandoc.Writers.RTF. This is no longer needed; we automatically handle embedded images using the PandocM functions. [API change] --- src/Text/Pandoc.hs | 3 +-- src/Text/Pandoc/Class.hs | 12 +++++------- src/Text/Pandoc/Readers/Docx.hs | 4 ++-- src/Text/Pandoc/Readers/RST.hs | 10 +++++----- src/Text/Pandoc/Readers/TWiki.hs | 2 +- src/Text/Pandoc/Writers/Docx.hs | 2 +- src/Text/Pandoc/Writers/EPUB.hs | 4 ++-- src/Text/Pandoc/Writers/ICML.hs | 4 ++-- src/Text/Pandoc/Writers/Math.hs | 4 ++-- src/Text/Pandoc/Writers/ODT.hs | 4 ++-- src/Text/Pandoc/Writers/RTF.hs | 34 +++++++++++++++++++--------------- 11 files changed, 42 insertions(+), 41 deletions(-) diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs index 036d3cdf5..3c3a79bb7 100644 --- a/src/Text/Pandoc.hs +++ b/src/Text/Pandoc.hs @@ -322,8 +322,7 @@ writers = [ ,("dokuwiki" , StringWriter writeDokuWiki) ,("zimwiki" , StringWriter writeZimWiki) ,("textile" , StringWriter writeTextile) - ,("rtf" , StringWriter $ \o -> - writeRTFWithEmbeddedImages o) + ,("rtf" , StringWriter writeRTF) ,("org" , StringWriter writeOrg) ,("asciidoc" , StringWriter writeAsciiDoc) ,("haddock" , StringWriter writeHaddock) diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index 1059f5324..3337de40a 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -36,14 +36,14 @@ module Text.Pandoc.Class ( PandocMonad(..) , PureState(..) , getPOSIXTime , getZonedTime - , warn + , addWarning + , addWarningWithPos , getWarnings , getMediaBag , setMediaBag , insertMedia , getInputFiles , getOutputFile - , addWarningWithPos , PandocIO(..) , PandocPure(..) , FileInfo(..) @@ -121,10 +121,8 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m, MonadState C -- Functions defined for all PandocMonad instances --- TODO should we rename this to avoid conflict with the like-named --- function from Shared? Perhaps "addWarning"? -warn :: PandocMonad m => String -> m () -warn msg = modify $ \st -> st{stWarnings = msg : stWarnings st} +addWarning :: PandocMonad m => String -> m () +addWarning msg = modify $ \st -> st{stWarnings = msg : stWarnings st} getWarnings :: PandocMonad m => m [String] getWarnings = gets stWarnings @@ -160,7 +158,7 @@ addWarningWithPos :: PandocMonad m -> ParserT [Char] ParserState m () addWarningWithPos mbpos msg = lift $ - warn $ + addWarning $ msg ++ maybe "" (\pos -> " " ++ show pos) mbpos -- diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs index 37fe5c532..16542fd1f 100644 --- a/src/Text/Pandoc/Readers/Docx.hs +++ b/src/Text/Pandoc/Readers/Docx.hs @@ -108,7 +108,7 @@ readDocx :: PandocMonad m readDocx opts bytes | Right archive <- toArchiveOrFail bytes , Right (docx, parserWarnings) <- archiveToDocxWithWarnings archive = do - mapM_ P.warn parserWarnings + mapM_ P.addWarning parserWarnings (meta, blks) <- docxToOutput opts docx return $ Pandoc meta blks readDocx _ _ = @@ -334,7 +334,7 @@ blocksToInlinesWarn cmtId blks = do notParaOrPlain (Plain _) = False notParaOrPlain _ = True when (not $ null $ filter notParaOrPlain blkList) - ((lift . lift) $ P.warn $ "Docx comment " ++ cmtId ++ " will not retain formatting") + ((lift . lift) $ P.addWarning $ "Docx comment " ++ cmtId ++ " will not retain formatting") return $ fromList $ blocksToInlines blkList parPartToInlines :: PandocMonad m => ParPart -> DocxContext m Inlines diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs index 078d2963c..df6a8114b 100644 --- a/src/Text/Pandoc/Readers/RST.hs +++ b/src/Text/Pandoc/Readers/RST.hs @@ -654,20 +654,20 @@ addNewRole roleString fields = do -- warn about syntax we ignore flip mapM_ fields $ \(key, _) -> case key of - "language" -> when (baseRole /= "code") $ lift $ P.warn $ + "language" -> when (baseRole /= "code") $ lift $ P.addWarning $ "ignoring :language: field because the parent of role :" ++ role ++ ": is :" ++ baseRole ++ ": not :code:" - "format" -> when (baseRole /= "raw") $ lift $ P.warn $ + "format" -> when (baseRole /= "raw") $ lift $ P.addWarning $ "ignoring :format: field because the parent of role :" ++ role ++ ": is :" ++ baseRole ++ ": not :raw:" - _ -> lift $ P.warn $ "ignoring unknown field :" ++ key ++ + _ -> lift $ P.addWarning $ "ignoring unknown field :" ++ key ++ ": in definition of role :" ++ role ++ ": in" when (parentRole == "raw" && countKeys "format" > 1) $ - lift $ P.warn $ + lift $ P.addWarning $ "ignoring :format: fields after the first in the definition of role :" ++ role ++": in" when (parentRole == "code" && countKeys "language" > 1) $ - lift $ P.warn $ + lift $ P.addWarning $ "ignoring :language: fields after the first in the definition of role :" ++ role ++": in" diff --git a/src/Text/Pandoc/Readers/TWiki.hs b/src/Text/Pandoc/Readers/TWiki.hs index b2b136f39..cc4f8f39c 100644 --- a/src/Text/Pandoc/Readers/TWiki.hs +++ b/src/Text/Pandoc/Readers/TWiki.hs @@ -58,7 +58,7 @@ readTWiki :: PandocMonad m -> m Pandoc readTWiki opts s = case readTWikiWithWarnings' opts s of Right (doc, warns) -> do - mapM_ P.warn warns + mapM_ P.addWarning warns return doc Left e -> throwError e diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 90261dede..3b1df6bd9 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -1182,7 +1182,7 @@ inlineToOpenXML' opts (Image attr alt (src, title)) = do res <- (lift . lift) $ P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src case res of Left (_ :: E.SomeException) -> do - (lift . lift) $ P.warn ("Could not find image `" ++ src ++ "', skipping...") + (lift . lift) $ P.addWarning ("Could not find image `" ++ src ++ "', skipping...") -- emit alt text inlinesToOpenXML opts alt Right (img, mt) -> do diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index e41aa96ad..b1266c4c9 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -398,7 +398,7 @@ pandocToEPUB opts doc@(Pandoc meta _) = do let matchingGlob f = do xs <- lift $ P.glob f when (null xs) $ - lift $ P.warn $ f ++ " did not match any font files." + lift $ P.addWarning $ f ++ " did not match any font files." return xs let mkFontEntry f = mkEntry (takeFileName f) `fmap` (lift $ P.readFileLazy f) fontFiles <- concat <$> mapM matchingGlob (writerEpubFonts opts') @@ -864,7 +864,7 @@ modifyMediaRef opts oldsrc = do (new, mbEntry) <- case res of Left _ -> do - lift $ P.warn $ "Could not find media `" ++ oldsrc ++ "', skipping..." + lift $ P.addWarning $ "Could not find media `" ++ oldsrc ++ "', skipping..." return (oldsrc, Nothing) Right (img,mbMime) -> do let new = "media/file" ++ show (length media) ++ diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index 7c42671f1..482e20f4b 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -537,13 +537,13 @@ imageICML opts style attr (src, _) = do res <- lift $ P.fetchItem (writerSourceURL opts) src imgS <- case res of Left (_) -> do - lift $ P.warn $ "Could not find image `" ++ src ++ "', skipping..." + lift $ P.addWarning $ "Could not find image `" ++ src ++ "', skipping..." return def Right (img, _) -> do case imageSize img of Right size -> return size Left msg -> do - lift $ P.warn $ "Could not determine image size in `" ++ + lift $ P.addWarning $ "Could not determine image size in `" ++ src ++ "': " ++ msg return def let (ow, oh) = sizeInPoints imgS diff --git a/src/Text/Pandoc/Writers/Math.hs b/src/Text/Pandoc/Writers/Math.hs index a7fe6d648..552db8b32 100644 --- a/src/Text/Pandoc/Writers/Math.hs +++ b/src/Text/Pandoc/Writers/Math.hs @@ -20,7 +20,7 @@ texMathToInlines mt inp = do case res of Right (Just ils) -> return ils Right (Nothing) -> do - warn $ "Could not render TeX math as unicode, rendering as raw TeX:\n" ++ inp + addWarning $ "Could not render TeX math as unicode, rendering as raw TeX:\n" ++ inp return [mkFallback mt inp] Left il -> return [il] @@ -40,7 +40,7 @@ convertMath writer mt str = do case writer dt <$> readTeX str of Right r -> return (Right r) Left e -> do - warn $ "Could not convert TeX math, rendering as raw TeX:\n" ++ + addWarning $ "Could not convert TeX math, rendering as raw TeX:\n" ++ str ++ "\n" ++ e return (Left $ mkFallback mt str) where dt = case mt of diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 02e84e26e..db9090e29 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -147,13 +147,13 @@ transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = do res <- lift $ P.fetchItem' (writerMediaBag opts) (writerSourceURL opts) src case res of Left (_ :: E.SomeException) -> do - lift $ P.warn $ "Could not find image `" ++ src ++ "', skipping..." + lift $ P.addWarning $ "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 - lift $ P.warn $ "Could not determine image size in `" ++ + lift $ P.addWarning $ "Could not determine image size in `" ++ src ++ "': " ++ msg return (100, 100) let dims = diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index f71c97334..32f70cb31 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -28,7 +28,6 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of 'Pandoc' documents to RTF (rich text format). -} module Text.Pandoc.Writers.RTF ( writeRTF - , writeRTFWithEmbeddedImages ) where import Text.Pandoc.Definition import Text.Pandoc.Options @@ -37,6 +36,7 @@ import Text.Pandoc.Writers.Shared import Text.Pandoc.Writers.Math import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Walk +import Text.Pandoc.Class (addWarning) import Data.List ( isSuffixOf, intercalate ) import Data.Char ( ord, chr, isDigit ) import qualified Data.ByteString as B @@ -64,7 +64,7 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = do _ -> throwError $ PandocSomeError "Unknown file type" sizeSpec <- case imageSize imgdata of Left msg -> do - P.warn $ "Could not determine image size in `" ++ + addWarning $ "Could not determine image size in `" ++ src ++ "': " ++ msg return "" Right sz -> return $ "\\picw" ++ show xpx ++ @@ -76,23 +76,27 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = do (xpt, ypt) = desiredSizeInPoints opts attr sz let raw = "{\\pict" ++ filetype ++ sizeSpec ++ "\\bin " ++ concat bytes ++ "}" - return $ if B.null imgdata - then x - else RawInline (Format "rtf") raw - _ -> return x + if B.null imgdata + then do + addWarning $ "Image " ++ src ++ " contained no data, skipping." + return x + else return $ RawInline (Format "rtf") raw + | otherwise -> do + addWarning $ "Image " ++ src ++ " is not a jpeg or png, skipping." + return x + Right (_, Nothing) -> do + addWarning $ "Could not determine image type for " ++ src ++ ", skipping." + return x + Left e -> do + addWarning $ "Could not fetch image " ++ src ++ "\n" ++ show e + return x rtfEmbedImage _ x = return x --- | Convert Pandoc to a string in rich text format, with --- images embedded as encoded binary data. TODO get rid of this, --- we don't need it now that we have writeRTF in PandocMonad. -writeRTFWithEmbeddedImages :: PandocMonad m - => WriterOptions -> Pandoc -> m String -writeRTFWithEmbeddedImages options doc = - writeRTF options =<< walkM (rtfEmbedImage options) doc - -- | Convert Pandoc to a string in rich text format. writeRTF :: PandocMonad m => WriterOptions -> Pandoc -> m String -writeRTF options (Pandoc meta@(Meta metamap) blocks) = do +writeRTF options doc = do + -- handle images + Pandoc meta@(Meta metamap) blocks <- walkM (rtfEmbedImage options) doc let spacer = not $ all null $ docTitle meta : docDate meta : docAuthors meta let toPlain (MetaBlocks [Para ils]) = MetaInlines ils toPlain x = x -- cgit v1.2.3