From 23c5b0d0f1901aa3ab68391f927de4f5278b5942 Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Sat, 26 Nov 2016 23:43:54 -0500 Subject: Implement Errors in PandocMonad Errors can be thrown purely with `throwError`. At the moment there are only three kinds of errors: 1. PandocFileReadError FilePath (for problems reading a file from the filesystem) 2. PandocShouldNeverHappenError String (for stuff that should never happen but we need to pattern-match anyway) 3. PandocSomeError String (a grab bag of everything else) Of course, we need to subdivide the third item in this list. --- src/Text/Pandoc/Class.hs | 18 +++++--- src/Text/Pandoc/Writers/EPUB.hs | 28 +++++++----- src/Text/Pandoc/Writers/FB2.hs | 5 ++- src/Text/Pandoc/Writers/HTML.hs | 70 ++++++++++++++++------------- src/Text/Pandoc/Writers/Man.hs | 57 +++++++++++++----------- src/Text/Pandoc/Writers/Markdown.hs | 19 ++++---- src/Text/Pandoc/Writers/OPML.hs | 16 ++++--- src/Text/Pandoc/Writers/RTF.hs | 11 ++--- src/Text/Pandoc/Writers/Texinfo.hs | 89 ++++++++++++++++++++++--------------- 9 files changed, 179 insertions(+), 134 deletions(-) diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index 64fd7e907..69d2bb761 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -107,8 +107,10 @@ getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime -- We can add to this as we go -data PandocExecutionError = PandocFileReadError String - deriving (Show, Typeable) +data PandocExecutionError = PandocFileReadError FilePath + | PandocShouldNeverHappenError String + | PandocSomeError String + deriving (Show, Typeable) -- Nothing in this for now, but let's put it there anyway. data PandocStateIO = PandocStateIO @@ -125,7 +127,9 @@ runIOorExplode ma = do eitherVal <- runIO ma case eitherVal of Right x -> return x - Left (PandocFileReadError s) -> error s + Left (PandocFileReadError fp) -> error $ "promple reading " ++ fp + Left (PandocShouldNeverHappenError s) -> error s + Left (PandocSomeError s) -> error s newtype PandocIO a = PandocIO { unPandocIO :: ExceptT PandocExecutionError (StateT PandocStateIO IO) a @@ -142,13 +146,13 @@ instance PandocMonad PandocIO where eitherBS <- liftIO (tryIOError $ BL.readFile s) case eitherBS of Right bs -> return bs - Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ s + Left _ -> throwError $ PandocFileReadError s -- TODO: Make this more sensitive to the different sorts of failure readDataFile mfp fname = do eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname) case eitherBS of Right bs -> return bs - Left _ -> throwError $ PandocFileReadError $ "file not found: " ++ fname + Left _ -> throwError $ PandocFileReadError fname fail = M.fail fetchItem ms s = liftIO $ IO.fetchItem ms s fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s @@ -235,7 +239,7 @@ instance PandocMonad PandocPure where fps <- asks envFiles case lookup fp fps of Just bs -> return (BL.fromStrict bs) - Nothing -> throwError $ PandocFileReadError "file not in state" + Nothing -> throwError $ PandocFileReadError fp readDataFile Nothing "reference.docx" = do (B.concat . BL.toChunks . fromArchive) <$> (getDefaultReferenceDocx Nothing) readDataFile Nothing "reference.odt" = do @@ -253,7 +257,7 @@ instance PandocMonad PandocPure where fps <- asks envFiles case lookup fp fps of Just bs -> return (Right (bs, getMimeType fp)) - Nothing -> return (Left $ E.toException $ PandocFileReadError "oops") + Nothing -> return (Left $ E.toException $ PandocFileReadError fp) fetchItem' media sourceUrl nm = do case lookupMedia nm media of diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 298561db6..580b12210 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -64,7 +64,8 @@ import Data.Char ( toLower, isDigit, isAlphaNum ) import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType) import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.HTML.TagSoup (Tag(TagOpen), fromAttrib, parseTags) -import Text.Pandoc.Class (PandocMonad) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) import qualified Text.Pandoc.Class as P -- A Chapter includes a list of blocks and maybe a section @@ -532,9 +533,9 @@ pandocToEPUB opts doc@(Pandoc meta _) = do let tocTitle = fromMaybe plainTitle $ metaValueToString <$> lookupMeta "toc-title" meta - let uuid = case epubIdentifier metadata of - (x:_) -> identifierText x -- use first identifier as UUID - [] -> error "epubIdentifier is null" -- shouldn't happen + uuid <- case epubIdentifier metadata of + (x:_) -> return $ identifierText x -- use first identifier as UUID + [] -> throwError $ PandocShouldNeverHappenError "epubIdentifier is null" -- shouldn't happen currentTime <- lift $ P.getCurrentTime let contentsData = UTF8.fromStringLazy $ ppTopElement $ unode "package" ! [("version", case version of @@ -590,8 +591,9 @@ pandocToEPUB opts doc@(Pandoc meta _) = do let tocLevel = writerTOCDepth opts - let navPointNode :: (Int -> String -> String -> [Element] -> Element) - -> S.Element -> State Int Element + let navPointNode :: PandocMonad m + => (Int -> String -> String -> [Element] -> Element) + -> S.Element -> StateT Int m Element navPointNode formatter (S.Sec _ nums (ident,_,_) ils children) = do n <- get modify (+1) @@ -601,15 +603,15 @@ pandocToEPUB opts doc@(Pandoc meta _) = do let tit = if writerNumberSections opts && not (null nums) then showNums nums ++ " " ++ tit' else tit' - let src = case lookup ident reftable of - Just x -> x - Nothing -> error (ident ++ " not found in reftable") + src <- case lookup ident reftable of + Just x -> return x + Nothing -> throwError $ PandocSomeError $ ident ++ " not found in reftable" let isSec (S.Sec lev _ _ _ _) = lev <= tocLevel isSec _ = False let subsecs = filter isSec children subs <- mapM (navPointNode formatter) subsecs return $ formatter n tit src subs - navPointNode _ (S.Blk _) = error "navPointNode encountered Blk" + navPointNode _ (S.Blk _) = throwError $ PandocSomeError "navPointNode encountered Blk" let navMapFormatter :: Int -> String -> String -> [Element] -> Element navMapFormatter n tit src subs = unode "navPoint" ! @@ -622,6 +624,7 @@ pandocToEPUB opts doc@(Pandoc meta _) = do [ unode "navLabel" $ unode "text" (stringify $ docTitle' meta) , unode "content" ! [("src","title_page.xhtml")] $ () ] + navMap <- lift $ evalStateT (mapM (navPointNode navMapFormatter) secs) 1 let tocData = UTF8.fromStringLazy $ ppTopElement $ unode "ncx" ! [("version","2005-1") ,("xmlns","http://www.daisy.org/z3986/2005/ncx/")] $ @@ -640,7 +643,7 @@ pandocToEPUB opts doc@(Pandoc meta _) = do ("content", toId img)] $ ()] , unode "docTitle" $ unode "text" $ plainTitle , unode "navMap" $ - tpNode : evalState (mapM (navPointNode navMapFormatter) secs) 1 + tpNode : navMap ] let tocEntry = mkEntry "toc.ncx" tocData @@ -654,11 +657,12 @@ pandocToEPUB opts doc@(Pandoc meta _) = do (_:_) -> [unode "ol" ! [("class","toc")] $ subs] let navtag = if epub3 then "nav" else "div" + tocBlocks <- lift $ evalStateT (mapM (navPointNode navXhtmlFormatter) secs) 1 let navBlocks = [RawBlock (Format "html") $ ppElement $ unode navtag ! ([("epub:type","toc") | epub3] ++ [("id","toc")]) $ [ unode "h1" ! [("id","toc-title")] $ tocTitle - , unode "ol" ! [("class","toc")] $ evalState (mapM (navPointNode navXhtmlFormatter) secs) 1]] + , unode "ol" ! [("class","toc")] $ tocBlocks ]] let landmarks = if epub3 then [RawBlock (Format "html") $ ppElement $ unode "nav" ! [("epub:type","landmarks") diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index 58bfe7615..5c22c8586 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -39,13 +39,14 @@ import Text.XML.Light import qualified Text.XML.Light as X import qualified Text.XML.Light.Cursor as XC import qualified Data.ByteString.Char8 as B8 +import Control.Monad.Except (throwError) import Text.Pandoc.Definition import Text.Pandoc.Options (WriterOptions(..), HTMLMathMethod(..), def) import Text.Pandoc.Shared (orderedListMarkers, isHeaderBlock, capitalize, linesToPara) -import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) import qualified Text.Pandoc.Class as P -- | Data to be written at the end of the document: @@ -348,7 +349,7 @@ blockToXml (DefinitionList defs) = needsBreak (Plain ins) = LineBreak `notElem` ins needsBreak _ = True blockToXml (Header _ _ _) = -- should never happen, see renderSections - error "unexpected header in section text" + throwError $ PandocShouldNeverHappenError "unexpected header in section text" blockToXml HorizontalRule = return [ el "empty-line" () , el "p" (txt (replicate 10 '—')) diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index 6f25939f0..4520708e4 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -68,7 +68,8 @@ import Text.XML.Light (unode, elChildren, unqual) import qualified Text.XML.Light as XML import System.FilePath (takeExtension) import Data.Aeson (Value) -import Text.Pandoc.Class (PandocMonad) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) data WriterState = WriterState { stNotes :: [Html] -- ^ List of notes @@ -101,26 +102,27 @@ nl opts = if writerWrapText opts == WrapNone -- | Convert Pandoc document to Html string. writeHtmlString :: PandocMonad m => WriterOptions -> Pandoc -> m String -writeHtmlString opts d = return $ - let (body, context) = evalState (pandocToHtml opts d) defaultWriterState - in case writerTemplate opts of - Nothing -> renderHtml body - Just tpl -> renderTemplate' tpl $ - defField "body" (renderHtml body) context +writeHtmlString opts d = do + (body, context) <- evalStateT (pandocToHtml opts d) defaultWriterState + return $ case writerTemplate opts of + Nothing -> renderHtml body + Just tpl -> renderTemplate' tpl $ + defField "body" (renderHtml body) context -- | Convert Pandoc document to Html structure. writeHtml :: PandocMonad m => WriterOptions -> Pandoc -> m Html -writeHtml opts d = return $ - let (body, context) = evalState (pandocToHtml opts d) defaultWriterState - in case writerTemplate opts of - Nothing -> body - Just tpl -> renderTemplate' tpl $ - defField "body" (renderHtml body) context +writeHtml opts d = do + (body, context) <- evalStateT (pandocToHtml opts d) defaultWriterState + return $ case writerTemplate opts of + Nothing -> renderHtml body + Just tpl -> renderTemplate' tpl $ + defField "body" (renderHtml body) context -- result is (title, authors, date, toc, body, new variables) -pandocToHtml :: WriterOptions +pandocToHtml :: PandocMonad m + => WriterOptions -> Pandoc - -> State WriterState (Html, Value) + -> StateT WriterState m (Html, Value) pandocToHtml opts (Pandoc meta blocks) = do metadata <- metaToJSON opts (fmap renderHtml . blockListToHtml opts) @@ -222,7 +224,7 @@ defList :: WriterOptions -> [Html] -> Html defList opts items = toList H.dl opts (items ++ [nl opts]) -- | Construct table of contents from list of elements. -tableOfContents :: WriterOptions -> [Element] -> State WriterState (Maybe Html) +tableOfContents :: PandocMonad m => WriterOptions -> [Element] -> StateT WriterState m (Maybe Html) tableOfContents _ [] = return Nothing tableOfContents opts sects = do let opts' = opts { writerIgnoreNotes = True } @@ -238,7 +240,7 @@ showSecNum = concat . intersperse "." . map show -- | Converts an Element to a list item for a table of contents, -- retrieving the appropriate identifier from state. -elementToListItem :: WriterOptions -> Element -> State WriterState (Maybe Html) +elementToListItem :: PandocMonad m => WriterOptions -> Element -> StateT WriterState m (Maybe Html) -- Don't include the empty headers created in slide shows -- shows when an hrule is used to separate slides without a new title: elementToListItem _ (Sec _ _ _ [Str "\0"] _) = return Nothing @@ -266,7 +268,7 @@ elementToListItem opts (Sec lev num (id',classes,_) headerText subsecs) elementToListItem _ _ = return Nothing -- | Convert an Element to Html. -elementToHtml :: Int -> WriterOptions -> Element -> State WriterState Html +elementToHtml :: PandocMonad m => Int -> WriterOptions -> Element -> StateT WriterState m Html elementToHtml _slideLevel opts (Blk block) = blockToHtml opts block elementToHtml slideLevel opts (Sec level num (id',classes,keyvals) title' elements) = do let slide = writerSlideVariant opts /= NoSlides && level <= slideLevel @@ -347,9 +349,9 @@ parseMailto s = do _ -> fail "not a mailto: URL" -- | Obfuscate a "mailto:" link. -obfuscateLink :: WriterOptions -> Attr -> Html -> String -> Html +obfuscateLink :: PandocMonad m => WriterOptions -> Attr -> Html -> String -> m Html obfuscateLink opts attr txt s | writerEmailObfuscation opts == NoObfuscation = - addAttrs opts attr $ H.a ! A.href (toValue s) $ txt + return $ addAttrs opts attr $ H.a ! A.href (toValue s) $ txt obfuscateLink opts attr (renderHtml -> txt) s = let meth = writerEmailObfuscation opts s' = map toLower (take 7 s) ++ drop 7 s @@ -365,9 +367,11 @@ obfuscateLink opts attr (renderHtml -> txt) s = in case meth of ReferenceObfuscation -> -- need to use preEscapedString or &'s are escaped to & in URL + return $ preEscapedString $ "" ++ (obfuscateString txt) ++ "" JavascriptObfuscation -> + return $ (H.script ! A.type_ "text/javascript" $ preEscapedString ("\n\n")) >> H.noscript (preEscapedString $ obfuscateString altText) - _ -> error $ "Unknown obfuscation method: " ++ show meth - _ -> addAttrs opts attr $ H.a ! A.href (toValue s) $ toHtml txt -- malformed email + _ -> throwError $ PandocSomeError $ "Unknown obfuscation method: " ++ show meth + _ -> return $ addAttrs opts attr $ H.a ! A.href (toValue s) $ toHtml txt -- malformed email -- | Obfuscate character as entity. obfuscateChar :: Char -> String @@ -435,7 +439,7 @@ treatAsImage fp = in null ext || ext `elem` imageExts -- | Convert Pandoc block element to HTML. -blockToHtml :: WriterOptions -> Block -> State WriterState Html +blockToHtml :: PandocMonad m => WriterOptions -> Block -> StateT WriterState m Html blockToHtml _ Null = return mempty blockToHtml opts (Plain lst) = inlineListToHtml opts lst -- title beginning with fig: indicates that the image is a figure @@ -625,11 +629,12 @@ blockToHtml opts (Table capt aligns widths headers rows') = do else tbl ! A.style (toValue $ "width:" ++ show (round (totalWidth * 100) :: Int) ++ "%;") -tableRowToHtml :: WriterOptions +tableRowToHtml :: PandocMonad m + => WriterOptions -> [Alignment] -> Int -> [[Block]] - -> State WriterState Html + -> StateT WriterState m Html tableRowToHtml opts aligns rownum cols' = do let mkcell = if rownum == 0 then H.th else H.td let rowclass = case rownum of @@ -649,11 +654,12 @@ alignmentToString alignment = case alignment of AlignCenter -> "center" AlignDefault -> "" -tableItemToHtml :: WriterOptions +tableItemToHtml :: PandocMonad m + => WriterOptions -> (Html -> Html) -> Alignment -> [Block] - -> State WriterState Html + -> StateT WriterState m Html tableItemToHtml opts tag' align' item = do contents <- blockListToHtml opts item let alignStr = alignmentToString align' @@ -671,12 +677,12 @@ toListItems opts items = map (toListItem opts) items ++ [nl opts] toListItem :: WriterOptions -> Html -> Html toListItem opts item = nl opts >> H.li item -blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html +blockListToHtml :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Html blockListToHtml opts lst = fmap (mconcat . intersperse (nl opts)) $ mapM (blockToHtml opts) lst -- | Convert list of Pandoc inline elements to HTML. -inlineListToHtml :: WriterOptions -> [Inline] -> State WriterState Html +inlineListToHtml :: PandocMonad m => WriterOptions -> [Inline] -> StateT WriterState m Html inlineListToHtml opts lst = mapM (inlineToHtml opts) lst >>= return . mconcat @@ -695,7 +701,7 @@ annotateMML e tex = math (unode "semantics" [cs, unode "annotation" (annotAttrs, -- | Convert Pandoc inline element to HTML. -inlineToHtml :: WriterOptions -> Inline -> State WriterState Html +inlineToHtml :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m Html inlineToHtml opts inline = case inline of (Str str) -> return $ strToHtml str @@ -818,7 +824,7 @@ inlineToHtml opts inline = | otherwise -> return mempty (Link attr txt (s,_)) | "mailto:" `isPrefixOf` s -> do linkText <- inlineListToHtml opts txt - return $ obfuscateLink opts attr linkText s + lift $ obfuscateLink opts attr linkText s (Link attr txt (s,tit)) -> do linkText <- inlineListToHtml opts txt let s' = case s of @@ -878,7 +884,7 @@ inlineToHtml opts inline = then result ! customAttribute "data-cites" (toValue citationIds) else result -blockListToNote :: WriterOptions -> String -> [Block] -> State WriterState Html +blockListToNote :: PandocMonad m => WriterOptions -> String -> [Block] -> StateT WriterState m Html blockListToNote opts ref blocks = -- If last block is Para or Plain, include the backlink at the end of -- that block. Otherwise, insert a new Plain block with the backlink. diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index 75c026463..c9530e4e1 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -41,7 +41,8 @@ import Data.Maybe (fromMaybe) import Text.Pandoc.Pretty import Text.Pandoc.Builder (deleteMeta) import Control.Monad.State -import Text.Pandoc.Class (PandocMonad) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) type Notes = [[Block]] data WriterState = WriterState { stNotes :: Notes @@ -49,10 +50,10 @@ data WriterState = WriterState { stNotes :: Notes -- | Convert Pandoc to Man. writeMan :: PandocMonad m => WriterOptions -> Pandoc -> m String -writeMan opts document = return $ evalState (pandocToMan opts document) (WriterState [] False) +writeMan opts document = evalStateT (pandocToMan opts document) (WriterState [] False) -- | Return groff man representation of document. -pandocToMan :: WriterOptions -> Pandoc -> State WriterState String +pandocToMan :: PandocMonad m => WriterOptions -> Pandoc -> StateT WriterState m String pandocToMan opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts @@ -94,7 +95,7 @@ pandocToMan opts (Pandoc meta blocks) = do Just tpl -> return $ renderTemplate' tpl context -- | Return man representation of notes. -notesToMan :: WriterOptions -> [[Block]] -> State WriterState Doc +notesToMan :: PandocMonad m => WriterOptions -> [[Block]] -> StateT WriterState m Doc notesToMan opts notes = if null notes then return empty @@ -102,7 +103,7 @@ notesToMan opts notes = return . (text ".SH NOTES" $$) . vcat -- | Return man representation of a note. -noteToMan :: WriterOptions -> Int -> [Block] -> State WriterState Doc +noteToMan :: PandocMonad m => WriterOptions -> Int -> [Block] -> StateT WriterState m Doc noteToMan opts num note = do contents <- blockListToMan opts note let marker = cr <> text ".SS " <> brackets (text (show num)) @@ -161,9 +162,10 @@ splitSentences xs = in if null rest then [sent] else sent : splitSentences rest -- | Convert Pandoc block element to man. -blockToMan :: WriterOptions -- ^ Options - -> Block -- ^ Block element - -> State WriterState Doc +blockToMan :: PandocMonad m + => WriterOptions -- ^ Options + -> Block -- ^ Block element + -> StateT WriterState m Doc blockToMan _ Null = return empty blockToMan opts (Div _ bs) = blockListToMan opts bs blockToMan opts (Plain inlines) = @@ -237,7 +239,7 @@ blockToMan opts (DefinitionList items) = do return (vcat contents) -- | Convert bullet list item (list of blocks) to man. -bulletListItemToMan :: WriterOptions -> [Block] -> State WriterState Doc +bulletListItemToMan :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Doc bulletListItemToMan _ [] = return empty bulletListItemToMan opts ((Para first):rest) = bulletListItemToMan opts ((Plain first):rest) @@ -255,11 +257,12 @@ bulletListItemToMan opts (first:rest) = do return $ text "\\[bu] .RS 2" $$ first' $$ rest' $$ text ".RE" -- | Convert ordered list item (a list of blocks) to man. -orderedListItemToMan :: WriterOptions -- ^ options - -> String -- ^ order marker for list item - -> Int -- ^ number of spaces to indent - -> [Block] -- ^ list item (list of blocks) - -> State WriterState Doc +orderedListItemToMan :: PandocMonad m + => WriterOptions -- ^ options + -> String -- ^ order marker for list item + -> Int -- ^ number of spaces to indent + -> [Block] -- ^ list item (list of blocks) + -> StateT WriterState m Doc orderedListItemToMan _ _ _ [] = return empty orderedListItemToMan opts num indent ((Para first):rest) = orderedListItemToMan opts num indent ((Plain first):rest) @@ -274,18 +277,19 @@ orderedListItemToMan opts num indent (first:rest) = do return $ first'' $$ rest'' -- | Convert definition list item (label, list of blocks) to man. -definitionListItemToMan :: WriterOptions - -> ([Inline],[[Block]]) - -> State WriterState Doc +definitionListItemToMan :: PandocMonad m + => WriterOptions + -> ([Inline],[[Block]]) + -> StateT WriterState m Doc definitionListItemToMan opts (label, defs) = do labelText <- inlineListToMan opts label contents <- if null defs then return empty else liftM vcat $ forM defs $ \blocks -> do - let (first, rest) = case blocks of - ((Para x):y) -> (Plain x,y) - (x:y) -> (x,y) - [] -> error "blocks is null" + (first, rest) <- case blocks of + ((Para x):y) -> return (Plain x,y) + (x:y) -> return (x,y) + [] -> throwError $ PandocSomeError "blocks is null" rest' <- liftM vcat $ mapM (\item -> blockToMan opts item) rest first' <- blockToMan opts first @@ -293,18 +297,19 @@ definitionListItemToMan opts (label, defs) = do return $ text ".TP" $$ nowrap (text ".B " <> labelText) $$ contents -- | Convert list of Pandoc block elements to man. -blockListToMan :: WriterOptions -- ^ Options - -> [Block] -- ^ List of block elements - -> State WriterState Doc +blockListToMan :: PandocMonad m + => WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> StateT WriterState m Doc blockListToMan opts blocks = mapM (blockToMan opts) blocks >>= (return . vcat) -- | Convert list of Pandoc inline elements to man. -inlineListToMan :: WriterOptions -> [Inline] -> State WriterState Doc +inlineListToMan :: PandocMonad m => WriterOptions -> [Inline] -> StateT WriterState m Doc inlineListToMan opts lst = mapM (inlineToMan opts) lst >>= (return . hcat) -- | Convert Pandoc inline element to man. -inlineToMan :: WriterOptions -> Inline -> State WriterState Doc +inlineToMan :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m Doc inlineToMan opts (Span _ ils) = inlineListToMan opts ils inlineToMan opts (Emph lst) = do contents <- inlineListToMan opts lst diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 787db10f9..4c33de65d 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -46,6 +46,7 @@ import Data.Ord ( comparing ) import Text.Pandoc.Pretty import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Except (throwError) import Text.Pandoc.Writers.HTML (writeHtmlString) import Text.Pandoc.Readers.TeXMath (texMathToInlines) import Text.HTML.TagSoup (parseTags, isTagText, Tag(..)) @@ -57,7 +58,7 @@ import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.Set as Set import Network.HTTP ( urlEncode ) -import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) type Notes = [[Block]] type Ref = ([Inline], Target, Attr) @@ -800,14 +801,14 @@ getReference attr label target = do case find (\(_,t,a) -> t == target && a == attr) (stRefs st) of Just (ref, _, _) -> return ref Nothing -> do - let label' = case find (\(l,_,_) -> l == label) (stRefs st) of - Just _ -> -- label is used; generate numerical label - case find (\n -> notElem [Str (show n)] - (map (\(l,_,_) -> l) (stRefs st))) - [1..(10000 :: Integer)] of - Just x -> [Str (show x)] - Nothing -> error "no unique label" - Nothing -> label + label' <- case find (\(l,_,_) -> l == label) (stRefs st) of + Just _ -> -- label is used; generate numerical label + case find (\n -> notElem [Str (show n)] + (map (\(l,_,_) -> l) (stRefs st))) + [1..(10000 :: Integer)] of + Just x -> return [Str (show x)] + Nothing -> throwError $ PandocSomeError "no unique label" + Nothing -> return label modify (\s -> s{ stRefs = (label', target, attr) : stRefs st }) return label' diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index ce415264d..4f832f962 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -40,7 +40,8 @@ import Text.Pandoc.Writers.Markdown (writeMarkdown) import Text.Pandoc.Pretty import Text.Pandoc.Compat.Time import qualified Text.Pandoc.Builder as B -import Text.Pandoc.Class (PandocMonad) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) -- | Convert Pandoc document to string in OPML format. writeOPML :: PandocMonad m => WriterOptions -> Pandoc -> m String @@ -82,15 +83,20 @@ convertDate ils = maybe "" showDateTimeRFC822 $ elementToOPML :: PandocMonad m => WriterOptions -> Element -> m Doc elementToOPML _ (Blk _) = return empty elementToOPML opts (Sec _ _num _ title elements) = do - let isBlk (Blk _) = True + let isBlk :: Element -> Bool + isBlk (Blk _) = True isBlk _ = False - fromBlk (Blk x) = x - fromBlk _ = error "fromBlk called on non-block" + + fromBlk :: PandocMonad m => Element -> m Block + fromBlk (Blk x) = return x + fromBlk _ = throwError $ PandocSomeError "fromBlk called on non-block" + (blocks, rest) = span isBlk elements htmlIls <- writeHtmlInlines title md <- if null blocks then return [] - else writeMarkdown def $ Pandoc nullMeta $ map fromBlk blocks + else do blks <- mapM fromBlk blocks + writeMarkdown def $ Pandoc nullMeta blks let attrs = [("text", htmlIls)] ++ [("_note", md)] o <- mapM (elementToOPML opts) rest return $ inTags True "outline" attrs $ vcat o diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 75b97a648..1ac906756 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -43,7 +43,8 @@ import qualified Data.ByteString as B import qualified Data.Map as M import Text.Printf ( printf ) import Text.Pandoc.ImageSize -import Text.Pandoc.Class (PandocMonad) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class (PandocMonad, PandocExecutionError(..)) import qualified Text.Pandoc.Class as P -- | Convert Image inlines into a raw RTF embedded image, read from a file, @@ -56,10 +57,10 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = do Right (imgdata, Just mime) | mime == "image/jpeg" || mime == "image/png" -> do let bytes = map (printf "%02x") $ B.unpack imgdata - let filetype = case mime of - "image/jpeg" -> "\\jpegblip" - "image/png" -> "\\pngblip" - _ -> error "Unknown file type" + filetype <- case mime of + "image/jpeg" -> return "\\jpegblip" + "image/png" -> return "\\pngblip" + _ -> throwError $ PandocSomeError "Unknown file type" sizeSpec <- case imageSize imgdata of Left msg -> do P.warn $ "Could not determine image size in `" ++ diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index fac7f02ab..dd5d5ee5d 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -44,7 +44,8 @@ import Text.Pandoc.ImageSize import Network.URI ( isURI, unEscapeString ) import System.FilePath import qualified Data.Set as Set -import Text.Pandoc.Class ( PandocMonad ) +import Control.Monad.Except (throwError) +import Text.Pandoc.Class ( PandocMonad, PandocExecutionError(..) ) data WriterState = WriterState { stStrikeout :: Bool -- document contains strikeout @@ -60,10 +61,12 @@ data WriterState = - generated .texi files don't work when run through texi2dvi -} +type TI m = StateT WriterState m + -- | Convert Pandoc to Texinfo. writeTexinfo :: PandocMonad m => WriterOptions -> Pandoc -> m String -writeTexinfo options document = return $ - evalState (pandocToTexinfo options $ wrapTop document) $ +writeTexinfo options document = + evalStateT (pandocToTexinfo options $ wrapTop document) $ WriterState { stStrikeout = False, stSuperscript = False, stEscapeComma = False, stSubscript = False, stIdentifiers = Set.empty, stOptions = options} @@ -73,7 +76,7 @@ wrapTop :: Pandoc -> Pandoc wrapTop (Pandoc meta blocks) = Pandoc meta (Header 0 nullAttr (docTitle meta) : blocks) -pandocToTexinfo :: WriterOptions -> Pandoc -> State WriterState String +pandocToTexinfo :: PandocMonad m => WriterOptions -> Pandoc -> TI m String pandocToTexinfo options (Pandoc meta blocks) = do let titlePage = not $ all null $ docTitle meta : docDate meta : docAuthors meta @@ -111,7 +114,7 @@ stringToTexinfo = escapeStringUsing texinfoEscapes , ('\x2019', "'") ] -escapeCommas :: State WriterState Doc -> State WriterState Doc +escapeCommas :: PandocMonad m => TI m Doc -> TI m Doc escapeCommas parser = do oldEscapeComma <- gets stEscapeComma modify $ \st -> st{ stEscapeComma = True } @@ -124,8 +127,9 @@ inCmd :: String -> Doc -> Doc inCmd cmd contents = char '@' <> text cmd <> braces contents -- | Convert Pandoc block element to Texinfo. -blockToTexinfo :: Block -- ^ Block to convert - -> State WriterState Doc +blockToTexinfo :: PandocMonad m + => Block -- ^ Block to convert + -> TI m Doc blockToTexinfo Null = return empty @@ -221,17 +225,19 @@ blockToTexinfo (Header level _ lst) = do idsUsed <- gets stIdentifiers let id' = uniqueIdent lst idsUsed modify $ \st -> st{ stIdentifiers = Set.insert id' idsUsed } + sec <- seccmd level return $ if (level > 0) && (level <= 4) then blankline <> text "@node " <> node $$ - text (seccmd level) <> txt $$ + text sec <> txt $$ text "@anchor" <> braces (text $ '#':id') else txt where - seccmd 1 = "@chapter " - seccmd 2 = "@section " - seccmd 3 = "@subsection " - seccmd 4 = "@subsubsection " - seccmd _ = error "illegal seccmd level" + seccmd :: PandocMonad m => Int -> TI m String + seccmd 1 = return "@chapter " + seccmd 2 = return "@section " + seccmd 3 = return "@subsection " + seccmd 4 = return "@subsubsection " + seccmd _ = throwError $ PandocSomeError "illegal seccmd level" blockToTexinfo (Table caption aligns widths heads rows) = do headers <- if all null heads @@ -257,28 +263,32 @@ blockToTexinfo (Table caption aligns widths heads rows) = do inCmd "caption" captionText $$ text "@end float" -tableHeadToTexinfo :: [Alignment] +tableHeadToTexinfo :: PandocMonad m + => [Alignment] -> [[Block]] - -> State WriterState Doc + -> TI m Doc tableHeadToTexinfo = tableAnyRowToTexinfo "@headitem " -tableRowToTexinfo :: [Alignment] +tableRowToTexinfo :: PandocMonad m + => [Alignment] -> [[Block]] - -> State WriterState Doc + -> TI m Doc tableRowToTexinfo = tableAnyRowToTexinfo "@item " -tableAnyRowToTexinfo :: String +tableAnyRowToTexinfo :: PandocMonad m + => String -> [Alignment] -> [[Block]] - -> State WriterState Doc + -> TI m Doc tableAnyRowToTexinfo itemtype aligns cols = zipWithM alignedBlock aligns cols >>= return . (text itemtype $$) . foldl (\row item -> row $$ (if isEmpty row then empty else text " @tab ") <> item) empty -alignedBlock :: Alignment +alignedBlock :: PandocMonad m + => Alignment -> [Block] - -> State WriterState Doc + -> TI m Doc -- XXX @flushleft and @flushright text won't get word wrapped. Since word -- wrapping is more important than alignment, we ignore the alignment. alignedBlock _ = blockListToTexinfo @@ -293,8 +303,9 @@ alignedBlock _ col = blockListToTexinfo col -} -- | Convert Pandoc block elements to Texinfo. -blockListToTexinfo :: [Block] - -> State WriterState Doc +blockListToTexinfo :: PandocMonad m + => [Block] + -> TI m Doc blockListToTexinfo [] = return empty blockListToTexinfo (x:xs) = do x' <- blockToTexinfo x @@ -336,15 +347,17 @@ collectNodes level (x:xs) = _ -> collectNodes level xs -makeMenuLine :: Block - -> State WriterState Doc +makeMenuLine :: PandocMonad m + => Block + -> TI m Doc makeMenuLine (Header _ _ lst) = do txt <- inlineListForNode lst return $ text "* " <> txt <> text "::" -makeMenuLine _ = error "makeMenuLine called with non-Header block" +makeMenuLine _ = throwError $ PandocSomeError "makeMenuLine called with non-Header block" -listItemToTexinfo :: [Block] - -> State WriterState Doc +listItemToTexinfo :: PandocMonad m + => [Block] + -> TI m Doc listItemToTexinfo lst = do contents <- blockListToTexinfo lst let spacer = case reverse lst of @@ -352,8 +365,9 @@ listItemToTexinfo lst = do _ -> empty return $ text "@item" $$ contents <> spacer -defListItemToTexinfo :: ([Inline], [[Block]]) - -> State WriterState Doc +defListItemToTexinfo :: PandocMonad m + => ([Inline], [[Block]]) + -> TI m Doc defListItemToTexinfo (term, defs) = do term' <- inlineListToTexinfo term let defToTexinfo bs = do d <- blockListToTexinfo bs @@ -364,13 +378,15 @@ defListItemToTexinfo (term, defs) = do return $ text "@item " <> term' $+$ vcat defs' -- | Convert list of inline elements to Texinfo. -inlineListToTexinfo :: [Inline] -- ^ Inlines to convert - -> State WriterState Doc +inlineListToTexinfo :: PandocMonad m + => [Inline] -- ^ Inlines to convert + -> TI m Doc inlineListToTexinfo lst = mapM inlineToTexinfo lst >>= return . hcat -- | Convert list of inline elements to Texinfo acceptable for a node name. -inlineListForNode :: [Inline] -- ^ Inlines to convert - -> State WriterState Doc +inlineListForNode :: PandocMonad m + => [Inline] -- ^ Inlines to convert + -> TI m Doc inlineListForNode = return . text . stringToTexinfo . filter (not . disallowedInNode) . stringify @@ -379,8 +395,9 @@ disallowedInNode :: Char -> Bool disallowedInNode c = c `elem` (".,:()" :: String) -- | Convert inline element to Texinfo -inlineToTexinfo :: Inline -- ^ Inline to convert - -> State WriterState Doc +inlineToTexinfo :: PandocMonad m + => Inline -- ^ Inline to convert + -> TI m Doc inlineToTexinfo (Span _ lst) = inlineListToTexinfo lst -- cgit v1.2.3