diff options
Diffstat (limited to 'src/Text/Pandoc/Writers')
| -rw-r--r-- | src/Text/Pandoc/Writers/AsciiDoc.hs | 6 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/ConTeXt.hs | 47 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Docbook.hs | 76 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Docx.hs | 19 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/EPUB.hs | 31 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/FB2.hs | 616 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/HTML.hs | 21 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/LaTeX.hs | 9 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Man.hs | 81 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Markdown.hs | 330 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/MediaWiki.hs | 52 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Native.hs | 10 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/ODT.hs | 19 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/OpenDocument.hs | 2 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Org.hs | 60 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/RST.hs | 51 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/RTF.hs | 85 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Texinfo.hs | 27 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Textile.hs | 31 |
19 files changed, 1173 insertions, 400 deletions
diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index 1913eb92b..e314cf70e 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -40,8 +40,8 @@ module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc) where import Text.Pandoc.Definition import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Shared -import Text.Pandoc.Parsing hiding (blankline) -import Text.ParserCombinators.Parsec ( runParser, GenParser ) +import Text.Pandoc.Options +import Text.Pandoc.Parsing hiding (blankline, space) import Data.List ( isPrefixOf, intersperse, intercalate ) import Text.Pandoc.Pretty import Control.Monad.State @@ -93,7 +93,7 @@ escapeString = escapeStringUsing escs where escs = backslashEscapes "{" -- | Ordered list start parser for use in Para below. -olMarker :: GenParser Char ParserState Char +olMarker :: Parser [Char] ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index 964320eb2..df11d79cc 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -20,10 +20,10 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.ConTeXt Copyright : Copyright (C) 2007-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha + Stability : alpha Portability : portable Conversion of 'Pandoc' format into ConTeXt. @@ -31,6 +31,7 @@ Conversion of 'Pandoc' format into ConTeXt. module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where import Text.Pandoc.Definition import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.Generic (queryWith) import Text.Printf ( printf ) import Data.List ( intercalate ) @@ -39,23 +40,23 @@ import Text.Pandoc.Pretty import Text.Pandoc.Templates ( renderTemplate ) import Network.URI ( isURI, unEscapeString ) -data WriterState = +data WriterState = WriterState { stNextRef :: Int -- number of next URL reference , stOrderedListLevel :: Int -- level of ordered list , stOptions :: WriterOptions -- writer options } orderedListStyles :: [[Char]] -orderedListStyles = cycle ["[n]","[a]", "[r]", "[g]"] +orderedListStyles = cycle ["[n]","[a]", "[r]", "[g]"] -- | Convert Pandoc to ConTeXt. writeConTeXt :: WriterOptions -> Pandoc -> String -writeConTeXt options document = +writeConTeXt options document = let defaultWriterState = WriterState { stNextRef = 1 , stOrderedListLevel = 0 , stOptions = options - } - in evalState (pandocToConTeXt options document) defaultWriterState + } + in evalState (pandocToConTeXt options document) defaultWriterState pandocToConTeXt :: WriterOptions -> Pandoc -> State WriterState String pandocToConTeXt options (Pandoc (Meta title authors date) blocks) = do @@ -120,7 +121,7 @@ elementToConTeXt opts (Sec level _ id' title' elements) = do return $ vcat (header' : innerContents) -- | Convert Pandoc block element to ConTeXt. -blockToConTeXt :: Block +blockToConTeXt :: Block -> State WriterState Doc blockToConTeXt Null = return empty blockToConTeXt (Plain lst) = inlineListToConTeXt lst @@ -128,7 +129,7 @@ blockToConTeXt (Para [Image txt (src,_)]) = do capt <- inlineListToConTeXt txt return $ blankline $$ "\\placefigure[here,nonumber]" <> braces capt <> braces ("\\externalfigure" <> brackets (text src)) <> blankline -blockToConTeXt (Para lst) = do +blockToConTeXt (Para lst) = do contents <- inlineListToConTeXt lst return $ contents <> blankline blockToConTeXt (BlockQuote lst) = do @@ -147,18 +148,18 @@ blockToConTeXt (OrderedList (start, style', delim) lst) = do let level = stOrderedListLevel st put $ st {stOrderedListLevel = level + 1} contents <- mapM listItemToConTeXt lst - put $ st {stOrderedListLevel = level} + put $ st {stOrderedListLevel = level} let start' = if start == 1 then "" else "start=" ++ show start let delim' = case delim of DefaultDelim -> "" - Period -> "stopper=." - OneParen -> "stopper=)" + Period -> "stopper=." + OneParen -> "stopper=)" TwoParens -> "left=(,stopper=)" - let width = maximum $ map length $ take (length contents) + let width = maximum $ map length $ take (length contents) (orderedListMarkers (start, style', delim)) let width' = (toEnum width + 1) / 2 - let width'' = if width' > (1.5 :: Double) - then "width=" ++ show width' ++ "em" + let width'' = if width' > (1.5 :: Double) + then "width=" ++ show width' ++ "em" else "" let specs2Items = filter (not . null) [start', delim', width''] let specs2 = if null specs2Items @@ -166,8 +167,8 @@ blockToConTeXt (OrderedList (start, style', delim) lst) = do else "[" ++ intercalate "," specs2Items ++ "]" let style'' = case style' of DefaultStyle -> orderedListStyles !! level - Decimal -> "[n]" - Example -> "[n]" + Decimal -> "[n]" + Example -> "[n]" LowerRoman -> "[r]" UpperRoman -> "[R]" LowerAlpha -> "[a]" @@ -182,21 +183,21 @@ blockToConTeXt HorizontalRule = return $ "\\thinrule" <> blankline blockToConTeXt (Header level lst) = sectionHeader "" level lst blockToConTeXt (Table caption aligns widths heads rows) = do let colDescriptor colWidth alignment = (case alignment of - AlignLeft -> 'l' + AlignLeft -> 'l' AlignRight -> 'r' AlignCenter -> 'c' AlignDefault -> 'l'): if colWidth == 0 then "|" else ("p(" ++ printf "%.2f" colWidth ++ "\\textwidth)|") - let colDescriptors = "|" ++ (concat $ + let colDescriptors = "|" ++ (concat $ zipWith colDescriptor widths aligns) headers <- if all null heads then return empty - else liftM ($$ "\\HL") $ tableRowToConTeXt heads - captionText <- inlineListToConTeXt caption + else liftM ($$ "\\HL") $ tableRowToConTeXt heads + captionText <- inlineListToConTeXt caption let captionText' = if null caption then text "none" else captionText - rows' <- mapM tableRowToConTeXt rows + rows' <- mapM tableRowToConTeXt rows return $ "\\placetable[here]" <> braces captionText' $$ "\\starttable" <> brackets (text colDescriptors) $$ "\\HL" $$ headers $$ @@ -230,7 +231,7 @@ inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt lst -- | Convert inline element to ConTeXt inlineToConTeXt :: Inline -- ^ Inline to convert -> State WriterState Doc -inlineToConTeXt (Emph lst) = do +inlineToConTeXt (Emph lst) = do contents <- inlineListToConTeXt lst return $ braces $ "\\em " <> contents inlineToConTeXt (Strong lst) = do diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index 1bcf99dcf..e696fc63e 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Docbook Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -31,6 +31,7 @@ module Text.Pandoc.Writers.Docbook ( writeDocbook) where import Text.Pandoc.Definition import Text.Pandoc.XML import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Readers.TeXMath import Data.List ( isPrefixOf, intercalate, isSuffixOf ) @@ -47,23 +48,23 @@ authorToDocbook opts name' = let name = render Nothing $ inlinesToDocbook opts name' in if ',' `elem` name then -- last name first - let (lastname, rest) = break (==',') name + let (lastname, rest) = break (==',') name firstname = removeLeadingSpace rest in - inTagsSimple "firstname" (text $ escapeStringForXML firstname) <> - inTagsSimple "surname" (text $ escapeStringForXML lastname) + inTagsSimple "firstname" (text $ escapeStringForXML firstname) <> + inTagsSimple "surname" (text $ escapeStringForXML lastname) else -- last name last let namewords = words name - lengthname = length namewords + lengthname = length namewords (firstname, lastname) = case lengthname of - 0 -> ("","") + 0 -> ("","") 1 -> ("", name) n -> (intercalate " " (take (n-1) namewords), last namewords) - in inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$ - inTagsSimple "surname" (text $ escapeStringForXML lastname) + in inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$ + inTagsSimple "surname" (text $ escapeStringForXML lastname) -- | Convert Pandoc document to string in Docbook format. writeDocbook :: WriterOptions -> Pandoc -> String -writeDocbook opts (Pandoc (Meta tit auths dat) blocks) = +writeDocbook opts (Pandoc (Meta tit auths dat) blocks) = let title = inlinesToDocbook opts tit authors = map (authorToDocbook opts) auths date = inlinesToDocbook opts dat @@ -92,7 +93,7 @@ writeDocbook opts (Pandoc (Meta tit auths dat) blocks) = -- | Convert an Element to Docbook. elementToDocbook :: WriterOptions -> Int -> Element -> Doc -elementToDocbook opts _ (Blk block) = blockToDocbook opts block +elementToDocbook opts _ (Blk block) = blockToDocbook opts block elementToDocbook opts lvl (Sec _ _num id' title elements) = -- Docbook doesn't allow sections with no content, so insert some if needed let elements' = if null elements @@ -115,10 +116,10 @@ plainToPara :: Block -> Block plainToPara (Plain x) = Para x plainToPara x = x --- | Convert a list of pairs of terms and definitions into a list of +-- | Convert a list of pairs of terms and definitions into a list of -- Docbook varlistentrys. deflistItemsToDocbook :: WriterOptions -> [([Inline],[[Block]])] -> Doc -deflistItemsToDocbook opts items = +deflistItemsToDocbook opts items = vcat $ map (\(term, defs) -> deflistItemToDocbook opts term defs) items -- | Convert a term and a list of blocks into a Docbook varlistentry. @@ -144,13 +145,16 @@ blockToDocbook _ Null = empty blockToDocbook _ (Header _ _) = empty -- should not occur after hierarchicalize blockToDocbook opts (Plain lst) = inlinesToDocbook opts lst blockToDocbook opts (Para [Image txt (src,_)]) = - let capt = inlinesToDocbook opts txt + let alt = inlinesToDocbook opts txt + capt = if null txt + then empty + else inTagsSimple "title" alt in inTagsIndented "figure" $ - inTagsSimple "title" capt $$ + capt $$ (inTagsIndented "mediaobject" $ (inTagsIndented "imageobject" (selfClosingTag "imagedata" [("fileref",src)])) $$ - inTagsSimple "textobject" (inTagsSimple "phrase" capt)) + inTagsSimple "textobject" (inTagsSimple "phrase" alt)) blockToDocbook opts (Para lst) = inTagsIndented "para" $ inlinesToDocbook opts lst blockToDocbook opts (BlockQuote blocks) = @@ -167,9 +171,9 @@ blockToDocbook _ (CodeBlock (_,classes,_) str) = then [s] else languagesByExtension . map toLower $ s langs = concatMap langsFrom classes -blockToDocbook opts (BulletList lst) = - inTagsIndented "itemizedlist" $ listItemsToDocbook opts lst -blockToDocbook _ (OrderedList _ []) = empty +blockToDocbook opts (BulletList lst) = + inTagsIndented "itemizedlist" $ listItemsToDocbook opts lst +blockToDocbook _ (OrderedList _ []) = empty blockToDocbook opts (OrderedList (start, numstyle, _) (first:rest)) = let attribs = case numstyle of DefaultStyle -> [] @@ -182,12 +186,12 @@ blockToDocbook opts (OrderedList (start, numstyle, _) (first:rest)) = items = if start == 1 then listItemsToDocbook opts (first:rest) else (inTags True "listitem" [("override",show start)] - (blocksToDocbook opts $ map plainToPara first)) $$ - listItemsToDocbook opts rest + (blocksToDocbook opts $ map plainToPara first)) $$ + listItemsToDocbook opts rest in inTags True "orderedlist" attribs items -blockToDocbook opts (DefinitionList lst) = - inTagsIndented "variablelist" $ deflistItemsToDocbook opts lst -blockToDocbook _ (RawBlock "docbook" str) = text str -- raw XML block +blockToDocbook opts (DefinitionList lst) = + inTagsIndented "variablelist" $ deflistItemsToDocbook opts lst +blockToDocbook _ (RawBlock "docbook" str) = text str -- raw XML block -- we allow html for compatibility with earlier versions of pandoc blockToDocbook _ (RawBlock "html" str) = text str -- raw XML block blockToDocbook _ (RawBlock _ _) = empty @@ -237,26 +241,26 @@ inlinesToDocbook opts lst = hcat $ map (inlineToDocbook opts) lst -- | Convert an inline element to Docbook. inlineToDocbook :: WriterOptions -> Inline -> Doc -inlineToDocbook _ (Str str) = text $ escapeStringForXML str -inlineToDocbook opts (Emph lst) = +inlineToDocbook _ (Str str) = text $ escapeStringForXML str +inlineToDocbook opts (Emph lst) = inTagsSimple "emphasis" $ inlinesToDocbook opts lst -inlineToDocbook opts (Strong lst) = +inlineToDocbook opts (Strong lst) = inTags False "emphasis" [("role", "strong")] $ inlinesToDocbook opts lst -inlineToDocbook opts (Strikeout lst) = +inlineToDocbook opts (Strikeout lst) = inTags False "emphasis" [("role", "strikethrough")] $ inlinesToDocbook opts lst -inlineToDocbook opts (Superscript lst) = +inlineToDocbook opts (Superscript lst) = inTagsSimple "superscript" $ inlinesToDocbook opts lst -inlineToDocbook opts (Subscript lst) = +inlineToDocbook opts (Subscript lst) = inTagsSimple "subscript" $ inlinesToDocbook opts lst -inlineToDocbook opts (SmallCaps lst) = +inlineToDocbook opts (SmallCaps lst) = inTags False "emphasis" [("role", "smallcaps")] $ inlinesToDocbook opts lst -inlineToDocbook opts (Quoted _ lst) = +inlineToDocbook opts (Quoted _ lst) = inTagsSimple "quote" $ inlinesToDocbook opts lst inlineToDocbook opts (Cite _ lst) = - inlinesToDocbook opts lst -inlineToDocbook _ (Code _ str) = + inlinesToDocbook opts lst +inlineToDocbook _ (Code _ str) = inTagsSimple "literal" $ text (escapeStringForXML str) inlineToDocbook opts (Math t str) | isMathML (writerHTMLMathMethod opts) = @@ -282,7 +286,7 @@ inlineToDocbook _ Space = space inlineToDocbook opts (Link txt (src, _)) = if isPrefixOf "mailto:" src then let src' = drop 7 src - emailLink = inTagsSimple "email" $ text $ + emailLink = inTagsSimple "email" $ text $ escapeStringForXML $ src' in case txt of [Code _ s] | s == src' -> emailLink @@ -292,14 +296,14 @@ inlineToDocbook opts (Link txt (src, _)) = then inTags False "link" [("linkend", drop 1 src)] else inTags False "ulink" [("url", src)]) $ inlinesToDocbook opts txt -inlineToDocbook _ (Image _ (src, tit)) = +inlineToDocbook _ (Image _ (src, tit)) = let titleDoc = if null tit then empty else inTagsIndented "objectinfo" $ inTagsIndented "title" (text $ escapeStringForXML tit) in inTagsIndented "inlinemediaobject" $ inTagsIndented "imageobject" $ titleDoc $$ selfClosingTag "imagedata" [("fileref", src)] -inlineToDocbook opts (Note contents) = +inlineToDocbook opts (Note contents) = inTagsIndented "footnote" $ blocksToDocbook opts contents isMathML :: HTMLMathMethod -> Bool diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 396e7a482..05c9555c6 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -43,6 +43,7 @@ import Text.Pandoc.Generic import System.Directory import Text.Pandoc.ImageSize import Text.Pandoc.Shared hiding (Element) +import Text.Pandoc.Options import Text.Pandoc.Readers.TeXMath import Text.Pandoc.Highlighting ( highlight ) import Text.Highlighting.Kate.Types () @@ -93,14 +94,13 @@ mknode s attrs = add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) . node (unqual s) -- | Produce an Docx file from a Pandoc document. -writeDocx :: Maybe FilePath -- ^ Path specified by --reference-docx - -> WriterOptions -- ^ Writer options +writeDocx :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO B.ByteString -writeDocx mbRefDocx opts doc@(Pandoc (Meta tit auths date) _) = do +writeDocx opts doc@(Pandoc (Meta tit auths date) _) = do let datadir = writerUserDataDir opts refArchive <- liftM toArchive $ - case mbRefDocx of + case writerReferenceDocx opts of Just f -> B.readFile f Nothing -> do let defaultDocx = getDataFileName "reference.docx" >>= B.readFile @@ -543,7 +543,7 @@ inlineToOpenXML opts (SmallCaps lst) = inlineToOpenXML opts (Strikeout lst) = withTextProp (mknode "w:strike" [] ()) $ inlinesToOpenXML opts lst -inlineToOpenXML _ LineBreak = return [ mknode "w:br" [] () ] +inlineToOpenXML _ LineBreak = return [br] inlineToOpenXML _ (RawInline f str) | f == "openxml" = return [ x | Elem x <- parseXML str ] | otherwise = return [] @@ -562,16 +562,14 @@ inlineToOpenXML opts (Math DisplayMath str) = Left _ -> do fallback <- inlinesToOpenXML opts (readTeXMath str) return $ [br] ++ fallback ++ [br] - where br = mknode "w:br" [] () inlineToOpenXML opts (Cite _ lst) = inlinesToOpenXML opts lst inlineToOpenXML _ (Code attrs str) = withTextProp (rStyle "VerbatimChar") $ case highlight formatOpenXML attrs str of - Nothing -> intercalate [mknode "w:br" [] ()] + Nothing -> intercalate [br] `fmap` (mapM formattedString $ lines str) Just h -> return h - where formatOpenXML _fmtOpts = intercalate [mknode "w:br" [] ()] . - map (map toHlTok) + where formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok) toHlTok (toktype,tok) = mknode "w:r" [] [ mknode "w:rPr" [] [ rStyle $ show toktype ] @@ -669,3 +667,6 @@ inlineToOpenXML opts (Image alt (src, tit)) = do liftIO $ UTF8.hPutStrLn stderr $ "Could not find image `" ++ src ++ "', skipping..." inlinesToOpenXML opts alt + +br :: Element +br = mknode "w:r" [] [mknode "w:cr" [] () ] diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index b423f136f..46310e398 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -38,6 +38,7 @@ import Data.ByteString.Lazy.UTF8 ( fromString ) import Codec.Archive.Zip import Data.Time.Clock.POSIX import Text.Pandoc.Shared hiding ( Element ) +import Text.Pandoc.Options import Text.Pandoc.Definition import Text.Pandoc.Generic import Control.Monad.State @@ -52,12 +53,10 @@ import Prelude hiding (catch) import Control.Exception (catch, SomeException) -- | Produce an EPUB file from a Pandoc document. -writeEPUB :: Maybe String -- ^ EPUB stylesheet specified at command line - -> [FilePath] -- ^ Paths to fonts to embed - -> WriterOptions -- ^ Writer options +writeEPUB :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO B.ByteString -writeEPUB mbStylesheet fonts opts doc@(Pandoc meta _) = do +writeEPUB opts doc@(Pandoc meta _) = do epochtime <- floor `fmap` getPOSIXTime let mkEntry path content = toEntry path epochtime content let opts' = opts{ writerEmailObfuscation = NoObfuscation @@ -107,7 +106,7 @@ writeEPUB mbStylesheet fonts opts doc@(Pandoc meta _) = do -- handle fonts let mkFontEntry f = mkEntry (takeFileName f) `fmap` B.readFile f - fontEntries <- mapM mkFontEntry fonts + fontEntries <- mapM mkFontEntry $ writerEpubFonts opts -- body pages let isH1 (Header 1 _) = True @@ -232,7 +231,7 @@ writeEPUB mbStylesheet fonts opts doc@(Pandoc meta _) = do let appleEntry = mkEntry "META-INF/com.apple.ibooks.display-options.xml" apple -- stylesheet - stylesheet <- case mbStylesheet of + stylesheet <- case writerEpubStylesheet opts of Just s -> return s Nothing -> readDataFile (writerUserDataDir opts) "epub.css" let stylesheetEntry = mkEntry "stylesheet.css" $ fromString stylesheet @@ -249,12 +248,14 @@ metadataElement metadataXML uuid lang title authors date mbCoverImage = let userNodes = parseXML metadataXML elt = unode "metadata" ! [("xmlns:dc","http://purl.org/dc/elements/1.1/") ,("xmlns:opf","http://www.idpf.org/2007/opf")] $ - filter isDublinCoreElement $ onlyElems userNodes + filter isMetadataElement $ onlyElems userNodes dublinElements = ["contributor","coverage","creator","date", "description","format","identifier","language","publisher", "relation","rights","source","subject","title","type"] - isDublinCoreElement e = qPrefix (elName e) == Just "dc" && - qName (elName e) `elem` dublinElements + isMetadataElement e = (qPrefix (elName e) == Just "dc" && + qName (elName e) `elem` dublinElements) || + (qPrefix (elName e) == Nothing && + qName (elName e) `elem` ["link","meta"]) contains e n = not (null (findElements (QName n Nothing (Just "dc")) e)) newNodes = [ unode "dc:title" title | not (elt `contains` "title") ] ++ [ unode "dc:language" lang | not (elt `contains` "language") ] ++ @@ -288,10 +289,8 @@ transformInlines _ sourceDir picsRef (Image lab (src,tit) : xs) = do transformInlines (MathML _) _ _ (x@(Math _ _) : xs) = do let writeHtmlInline opts z = removeTrailingSpace $ writeHtmlString opts $ Pandoc (Meta [] [] []) [Plain [z]] - mathml = writeHtmlInline defaultWriterOptions{ - writerHTMLMathMethod = MathML Nothing } x - fallback = writeHtmlInline defaultWriterOptions{ - writerHTMLMathMethod = PlainMath } x + mathml = writeHtmlInline def{writerHTMLMathMethod = MathML Nothing } x + fallback = writeHtmlInline def{writerHTMLMathMethod = PlainMath } x inOps = "<ops:switch xmlns:ops=\"http://www.idpf.org/2007/ops\">" ++ "<ops:case required-namespace=\"http://www.w3.org/1998/Math/MathML\">" ++ mathml ++ "</ops:case><ops:default>" ++ fallback ++ "</ops:default>" ++ @@ -312,9 +311,9 @@ ppTopElement = ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++) . unEntity . unEntity ('&':'#':xs) = let (ds,ys) = break (==';') xs rest = drop 1 ys - in case reads ('\'':'\\':ds ++ "'") of - ((x,_):_) -> x : unEntity rest - _ -> '&':'#':unEntity xs + in case safeRead ('\'':'\\':ds ++ "'") of + Just x -> x : unEntity rest + Nothing -> '&':'#':unEntity xs unEntity (x:xs) = x : unEntity xs imageTypeOf :: FilePath -> Maybe String diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs new file mode 100644 index 000000000..301d80c54 --- /dev/null +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -0,0 +1,616 @@ +{- +Copyright (c) 2011-2012, Sergey Astanin +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | Conversion of 'Pandoc' documents to FB2 (FictionBook2) format. + +FictionBook is an XML-based e-book format. For more information see: +<http://www.fictionbook.org/index.php/Eng:XML_Schema_Fictionbook_2.1> + +-} +module Text.Pandoc.Writers.FB2 (writeFB2) where + +import Control.Monad.State (StateT, evalStateT, get, modify) +import Control.Monad.State (liftM, liftM2, liftIO) +import Data.ByteString.Base64 (encode) +import Data.Char (toUpper, toLower, isSpace, isAscii, isControl) +import Data.List (intersperse, intercalate, isPrefixOf) +import Data.Either (lefts, rights) +import Network.Browser (browse, request, setAllowRedirects, setOutHandler) +import Network.HTTP (catchIO_, getRequest, getHeaders, getResponseBody) +import Network.HTTP (lookupHeader, HeaderName(..), urlEncode) +import Network.URI (isURI, unEscapeString) +import System.FilePath (takeExtension) +import Text.XML.Light +import qualified Control.Exception as E +import qualified Data.ByteString as B +import qualified Text.XML.Light as X +import qualified Text.XML.Light.Cursor as XC + +import Text.Pandoc.Definition +import Text.Pandoc.Options (WriterOptions(..), HTMLMathMethod(..), def) +import Text.Pandoc.Shared (orderedListMarkers) +import Text.Pandoc.Generic (bottomUp) + +-- | Data to be written at the end of the document: +-- (foot)notes, URLs, references, images. +data FbRenderState = FbRenderState + { footnotes :: [ (Int, String, [Content]) ] -- ^ #, ID, text + , imagesToFetch :: [ (String, String) ] -- ^ filename, URL or path + , parentListMarker :: String -- ^ list marker of the parent ordered list + , parentBulletLevel :: Int -- ^ nesting level of the unordered list + , writerOptions :: WriterOptions + } deriving (Show) + +-- | FictionBook building monad. +type FBM = StateT FbRenderState IO + +newFB :: FbRenderState +newFB = FbRenderState { footnotes = [], imagesToFetch = [] + , parentListMarker = "", parentBulletLevel = 0 + , writerOptions = def } + +data ImageMode = NormalImage | InlineImage deriving (Eq) +instance Show ImageMode where + show NormalImage = "imageType" + show InlineImage = "inlineImageType" + +-- | Produce an FB2 document from a 'Pandoc' document. +writeFB2 :: WriterOptions -- ^ conversion options + -> Pandoc -- ^ document to convert + -> IO String -- ^ FictionBook2 document (not encoded yet) +writeFB2 opts (Pandoc meta blocks) = flip evalStateT newFB $ do + modify (\s -> s { writerOptions = opts { writerStandalone = True } }) + desc <- description meta + fp <- frontpage meta + secs <- renderSections 1 blocks + let body = el "body" $ fp ++ secs + notes <- renderFootnotes + (imgs,missing) <- liftM imagesToFetch get >>= \s -> liftIO (fetchImages s) + let body' = replaceImagesWithAlt missing body + let fb2_xml = el "FictionBook" (fb2_attrs, [desc, body'] ++ notes ++ imgs) + return $ xml_head ++ (showContent fb2_xml) + where + xml_head = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" + fb2_attrs = + let xmlns = "http://www.gribuser.ru/xml/fictionbook/2.0" + xlink = "http://www.w3.org/1999/xlink" + in [ uattr "xmlns" xmlns + , attr ("xmlns", "l") xlink ] + -- + frontpage :: Meta -> FBM [Content] + frontpage meta' = do + t <- cMapM toXml . docTitle $ meta' + return $ + [ el "title" (el "p" t) + , el "annotation" (map (el "p" . cMap plain) + (docAuthors meta' ++ [docDate meta'])) + ] + description :: Meta -> FBM Content + description meta' = do + bt <- booktitle meta' + let as = authors meta' + dd <- docdate meta' + return $ el "description" + [ el "title-info" (bt ++ as ++ dd) + , el "document-info" [ el "program-used" "pandoc" ] -- FIXME: +version + ] + booktitle :: Meta -> FBM [Content] + booktitle meta' = do + t <- cMapM toXml . docTitle $ meta' + return $ if null t + then [] + else [ el "book-title" t ] + authors :: Meta -> [Content] + authors meta' = cMap author (docAuthors meta') + author :: [Inline] -> [Content] + author ss = + let ws = words . cMap plain $ ss + email = (el "email") `fmap` (take 1 $ filter ('@' `elem`) ws) + ws' = filter ('@' `notElem`) ws + names = case ws' of + (nickname:[]) -> [ el "nickname" nickname ] + (fname:lname:[]) -> [ el "first-name" fname + , el "last-name" lname ] + (fname:rest) -> [ el "first-name" fname + , el "middle-name" (concat . init $ rest) + , el "last-name" (last rest) ] + ([]) -> [] + in list $ el "author" (names ++ email) + docdate :: Meta -> FBM [Content] + docdate meta' = do + let ss = docDate meta' + d <- cMapM toXml ss + return $ if null d + then [] + else [el "date" d] + +-- | Divide the stream of blocks into sections and convert to XML +-- representation. +renderSections :: Int -> [Block] -> FBM [Content] +renderSections level blocks = do + let secs = splitSections level blocks + mapM (renderSection level) secs + +renderSection :: Int -> ([Inline], [Block]) -> FBM Content +renderSection level (ttl, body) = do + title <- if null ttl + then return [] + else return . list . el "title" . formatTitle $ ttl + content <- if (hasSubsections body) + then renderSections (level + 1) body + else cMapM blockToXml body + return $ el "section" (title ++ content) + where + hasSubsections = any isHeader + isHeader (Header _ _) = True + isHeader _ = False + +-- | Only <p> and <empty-line> are allowed within <title> in FB2. +formatTitle :: [Inline] -> [Content] +formatTitle inlines = + let lns = split isLineBreak inlines + lns' = map (el "p" . cMap plain) lns + in intersperse (el "empty-line" ()) lns' + +split :: (a -> Bool) -> [a] -> [[a]] +split _ [] = [] +split cond xs = let (b,a) = break cond xs + in (b:split cond (drop 1 a)) + +isLineBreak :: Inline -> Bool +isLineBreak LineBreak = True +isLineBreak _ = False + +-- | Divide the stream of block elements into sections: [(title, blocks)]. +splitSections :: Int -> [Block] -> [([Inline], [Block])] +splitSections level blocks = reverse $ revSplit (reverse blocks) + where + revSplit [] = [] + revSplit rblocks = + let (lastsec, before) = break sameLevel rblocks + (header, prevblocks) = + case before of + ((Header n title):prevblocks') -> + if n == level + then (title, prevblocks') + else ([], before) + _ -> ([], before) + in (header, reverse lastsec) : revSplit prevblocks + sameLevel (Header n _) = n == level + sameLevel _ = False + +-- | Make another FictionBook body with footnotes. +renderFootnotes :: FBM [Content] +renderFootnotes = do + fns <- footnotes `liftM` get + if null fns + then return [] -- no footnotes + else return . list $ + el "body" ([uattr "name" "notes"], map renderFN (reverse fns)) + where + renderFN (n, idstr, cs) = + let fn_texts = (el "title" (el "p" (show n))) : cs + in el "section" ([uattr "id" idstr], fn_texts) + +-- | Fetch images and encode them for the FictionBook XML. +-- Return image data and a list of hrefs of the missing images. +fetchImages :: [(String,String)] -> IO ([Content],[String]) +fetchImages links = do + imgs <- mapM (uncurry fetchImage) links + return $ (rights imgs, lefts imgs) + +-- | Fetch image data from disk or from network and make a <binary> XML section. +-- Return either (Left hrefOfMissingImage) or (Right xmlContent). +fetchImage :: String -> String -> IO (Either String Content) +fetchImage href link = do + mbimg <- + case (isURI link, readDataURI link) of + (True, Just (mime,_,True,base64)) -> + let mime' = map toLower mime + in if mime' == "image/png" || mime' == "image/jpeg" + then return (Just (mime',base64)) + else return Nothing + (True, Just _) -> return Nothing -- not base64-encoded + (True, Nothing) -> fetchURL link + (False, _) -> do + d <- nothingOnError $ B.readFile (unEscapeString link) + let t = case map toLower (takeExtension link) of + ".png" -> Just "image/png" + ".jpg" -> Just "image/jpeg" + ".jpeg" -> Just "image/jpeg" + ".jpe" -> Just "image/jpeg" + _ -> Nothing -- only PNG and JPEG are supported in FB2 + return $ liftM2 (,) t (liftM (toStr . encode) d) + case mbimg of + Just (imgtype, imgdata) -> do + return . Right $ el "binary" + ( [uattr "id" href + , uattr "content-type" imgtype] + , txt imgdata ) + _ -> return (Left ('#':href)) + where + nothingOnError :: (IO B.ByteString) -> (IO (Maybe B.ByteString)) + nothingOnError action = liftM Just action `E.catch` omnihandler + omnihandler :: E.SomeException -> IO (Maybe B.ByteString) + omnihandler _ = return Nothing + +-- | Extract mime type and encoded data from the Data URI. +readDataURI :: String -- ^ URI + -> Maybe (String,String,Bool,String) + -- ^ Maybe (mime,charset,isBase64,data) +readDataURI uri = + let prefix = "data:" + in if not (prefix `isPrefixOf` uri) + then Nothing + else + let rest = drop (length prefix) uri + meta = takeWhile (/= ',') rest -- without trailing ',' + uridata = drop (length meta + 1) rest + parts = split (== ';') meta + (mime,cs,enc)=foldr upd ("text/plain","US-ASCII",False) parts + in Just (mime,cs,enc,uridata) + where + upd str m@(mime,cs,enc) + | isMimeType str = (str,cs,enc) + | "charset=" `isPrefixOf` str = (mime,drop (length "charset=") str,enc) + | str == "base64" = (mime,cs,True) + | otherwise = m + +-- Without parameters like ;charset=...; see RFC 2045, 5.1 +isMimeType :: String -> Bool +isMimeType s = + case split (=='/') s of + [mtype,msubtype] -> + ((map toLower mtype) `elem` types + || "x-" `isPrefixOf` (map toLower mtype)) + && all valid mtype + && all valid msubtype + _ -> False + where + types = ["text","image","audio","video","application","message","multipart"] + valid c = isAscii c && not (isControl c) && not (isSpace c) && + c `notElem` "()<>@,;:\\\"/[]?=" + +-- | Fetch URL, return its Content-Type and binary data on success. +fetchURL :: String -> IO (Maybe (String, String)) +fetchURL url = do + flip catchIO_ (return Nothing) $ do + r <- browse $ do + setOutHandler (const (return ())) + setAllowRedirects True + liftM snd . request . getRequest $ url + let content_type = lookupHeader HdrContentType (getHeaders r) + content <- liftM (Just . toStr . encode . toBS) . getResponseBody $ Right r + return $ liftM2 (,) content_type content + where + +toBS :: String -> B.ByteString +toBS = B.pack . map (toEnum . fromEnum) + +toStr :: B.ByteString -> String +toStr = map (toEnum . fromEnum) . B.unpack + +footnoteID :: Int -> String +footnoteID i = "n" ++ (show i) + +linkID :: Int -> String +linkID i = "l" ++ (show i) + +-- | Convert a block-level Pandoc's element to FictionBook XML representation. +blockToXml :: Block -> FBM [Content] +blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 +blockToXml (Para [Math DisplayMath formula]) = insertMath NormalImage formula +blockToXml (Para [img@(Image _ _)]) = insertImage NormalImage img +blockToXml (Para ss) = liftM (list . el "p") $ cMapM toXml ss +blockToXml (CodeBlock _ s) = return . spaceBeforeAfter . + map (el "p" . el "code") . lines $ s +blockToXml (RawBlock _ s) = return . spaceBeforeAfter . + map (el "p" . el "code") . lines $ s +blockToXml (BlockQuote bs) = liftM (list . el "cite") $ cMapM blockToXml bs +blockToXml (OrderedList a bss) = do + state <- get + let pmrk = parentListMarker state + let markers = map ((pmrk ++ " ") ++) $ orderedListMarkers a + let mkitem mrk bs = do + modify (\s -> s { parentListMarker = mrk }) + itemtext <- cMapM blockToXml . paraToPlain $ bs + modify (\s -> s { parentListMarker = pmrk }) -- old parent marker + return . el "p" $ [ txt mrk, txt " " ] ++ itemtext + mapM (uncurry mkitem) (zip markers bss) +blockToXml (BulletList bss) = do + state <- get + let level = parentBulletLevel state + let pmrk = parentListMarker state + let prefix = replicate (length pmrk) ' ' + let bullets = ["\x2022", "\x25e6", "*", "\x2043", "\x2023"] + let mrk = prefix ++ bullets !! (level `mod` (length bullets)) + let mkitem bs = do + modify (\s -> s { parentBulletLevel = (level+1) }) + itemtext <- cMapM blockToXml . paraToPlain $ bs + modify (\s -> s { parentBulletLevel = level }) -- restore bullet level + return $ el "p" $ [ txt (mrk ++ " ") ] ++ itemtext + mapM mkitem bss +blockToXml (DefinitionList defs) = + cMapM mkdef defs + where + mkdef (term, bss) = do + def' <- cMapM (cMapM blockToXml . sep . paraToPlain . map indent) bss + t <- wrap "strong" term + return [ el "p" t, el "p" def' ] + sep blocks = + if all needsBreak blocks then + blocks ++ [Plain [LineBreak]] + else + blocks + needsBreak (Para _) = False + needsBreak (Plain ins) = LineBreak `notElem` ins + needsBreak _ = True +blockToXml (Header _ _) = -- should never happen, see renderSections + error "unexpected header in section text" +blockToXml HorizontalRule = return + [ el "empty-line" () + , el "p" (txt (replicate 10 '—')) + , el "empty-line" () ] +blockToXml (Table caption aligns _ headers rows) = do + hd <- mkrow "th" headers aligns + bd <- mapM (\r -> mkrow "td" r aligns) rows + c <- return . el "emphasis" =<< cMapM toXml caption + return [el "table" (hd : bd), el "p" c] + where + mkrow :: String -> [TableCell] -> [Alignment] -> FBM Content + mkrow tag cells aligns' = + (el "tr") `liftM` (mapM (mkcell tag) (zip cells aligns')) + -- + mkcell :: String -> (TableCell, Alignment) -> FBM Content + mkcell tag (cell, align) = do + cblocks <- cMapM blockToXml cell + return $ el tag ([align_attr align], cblocks) + -- + align_attr a = Attr (QName "align" Nothing Nothing) (align_str a) + align_str AlignLeft = "left" + align_str AlignCenter = "center" + align_str AlignRight = "right" + align_str AlignDefault = "left" +blockToXml Null = return [] + +-- Replace paragraphs with plain text and line break. +-- Necessary to simulate multi-paragraph lists in FB2. +paraToPlain :: [Block] -> [Block] +paraToPlain [] = [] +paraToPlain (Para inlines : rest) = + let p = (Plain (inlines ++ [LineBreak])) + in p : paraToPlain rest +paraToPlain (p:rest) = p : paraToPlain rest + +-- Simulate increased indentation level. Will not really work +-- for multi-line paragraphs. +indent :: Block -> Block +indent = indentBlock + where + -- indentation space + spacer :: String + spacer = replicate 4 ' ' + -- + indentBlock (Plain ins) = Plain ((Str spacer):ins) + indentBlock (Para ins) = Para ((Str spacer):ins) + indentBlock (CodeBlock a s) = + let s' = unlines . map (spacer++) . lines $ s + in CodeBlock a s' + indentBlock (BlockQuote bs) = BlockQuote (map indent bs) + indentBlock (Header l ins) = Header l (indentLines ins) + indentBlock everythingElse = everythingElse + -- indent every (explicit) line + indentLines :: [Inline] -> [Inline] + indentLines ins = let lns = split isLineBreak ins :: [[Inline]] + in intercalate [LineBreak] $ map ((Str spacer):) lns + +-- | Convert a Pandoc's Inline element to FictionBook XML representation. +toXml :: Inline -> FBM [Content] +toXml (Str s) = return [txt s] +toXml (Emph ss) = list `liftM` wrap "emphasis" ss +toXml (Strong ss) = list `liftM` wrap "strong" ss +toXml (Strikeout ss) = list `liftM` wrap "strikethrough" ss +toXml (Superscript ss) = list `liftM` wrap "sup" ss +toXml (Subscript ss) = list `liftM` wrap "sub" ss +toXml (SmallCaps ss) = cMapM toXml $ bottomUp (map toUpper) ss +toXml (Quoted SingleQuote ss) = do -- FIXME: should be language-specific + inner <- cMapM toXml ss + return $ [txt "‘"] ++ inner ++ [txt "’"] +toXml (Quoted DoubleQuote ss) = do + inner <- cMapM toXml ss + return $ [txt "“"] ++ inner ++ [txt "”"] +toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles +toXml (Code _ s) = return [el "code" s] +toXml Space = return [txt " "] +toXml LineBreak = return [el "empty-line" ()] +toXml (Math _ formula) = insertMath InlineImage formula +toXml (RawInline _ _) = return [] -- raw TeX and raw HTML are suppressed +toXml (Link text (url,ttl)) = do + fns <- footnotes `liftM` get + let n = 1 + length fns + let ln_id = linkID n + let ln_ref = list . el "sup" . txt $ "[" ++ show n ++ "]" + ln_text <- cMapM toXml text + let ln_desc = + let ttl' = dropWhile isSpace ttl + in if null ttl' + then list . el "p" $ el "code" url + else list . el "p" $ [ txt (ttl' ++ ": "), el "code" url ] + modify (\s -> s { footnotes = (n, ln_id, ln_desc) : fns }) + return $ ln_text ++ + [ el "a" + ( [ attr ("l","href") ('#':ln_id) + , uattr "type" "note" ] + , ln_ref) ] +toXml img@(Image _ _) = insertImage InlineImage img +toXml (Note bs) = do + fns <- footnotes `liftM` get + let n = 1 + length fns + let fn_id = footnoteID n + fn_desc <- cMapM blockToXml bs + modify (\s -> s { footnotes = (n, fn_id, fn_desc) : fns }) + let fn_ref = el "sup" . txt $ "[" ++ show n ++ "]" + return . list $ el "a" ( [ attr ("l","href") ('#':fn_id) + , uattr "type" "note" ] + , fn_ref ) + +insertMath :: ImageMode -> String -> FBM [Content] +insertMath immode formula = do + htmlMath <- return . writerHTMLMathMethod . writerOptions =<< get + case htmlMath of + WebTeX url -> do + let alt = [Code nullAttr formula] + let imgurl = url ++ urlEncode formula + let img = Image alt (imgurl, "") + insertImage immode img + _ -> return [el "code" formula] + +insertImage :: ImageMode -> Inline -> FBM [Content] +insertImage immode (Image alt (url,ttl)) = do + images <- imagesToFetch `liftM` get + let n = 1 + length images + let fname = "image" ++ show n + modify (\s -> s { imagesToFetch = (fname, url) : images }) + let ttlattr = case (immode, null ttl) of + (NormalImage, False) -> [ uattr "title" ttl ] + _ -> [] + return . list $ + el "image" $ + [ attr ("l","href") ('#':fname) + , attr ("l","type") (show immode) + , uattr "alt" (cMap plain alt) ] + ++ ttlattr +insertImage _ _ = error "unexpected inline instead of image" + +replaceImagesWithAlt :: [String] -> Content -> Content +replaceImagesWithAlt missingHrefs body = + let cur = XC.fromContent body + cur' = replaceAll cur + in XC.toTree . XC.root $ cur' + where + -- + replaceAll :: XC.Cursor -> XC.Cursor + replaceAll c = + let n = XC.current c + c' = if isImage n && isMissing n + then XC.modifyContent replaceNode c + else c + in case XC.nextDF c' of + (Just cnext) -> replaceAll cnext + Nothing -> c' -- end of document + -- + isImage :: Content -> Bool + isImage (Elem e) = (elName e) == (uname "image") + isImage _ = False + -- + isMissing (Elem img@(Element _ _ _ _)) = + let imgAttrs = elAttribs img + badAttrs = map (attr ("l","href")) missingHrefs + in any (`elem` imgAttrs) badAttrs + isMissing _ = False + -- + replaceNode :: Content -> Content + replaceNode n@(Elem img@(Element _ _ _ _)) = + let attrs = elAttribs img + alt = getAttrVal attrs (uname "alt") + imtype = getAttrVal attrs (qname "l" "type") + in case (alt, imtype) of + (Just alt', Just imtype') -> + if imtype' == show NormalImage + then el "p" alt' + else txt alt' + (Just alt', Nothing) -> txt alt' -- no type attribute + _ -> n -- don't replace if alt text is not found + replaceNode n = n + -- + getAttrVal :: [X.Attr] -> QName -> Maybe String + getAttrVal attrs name = + case filter ((name ==) . attrKey) attrs of + (a:_) -> Just (attrVal a) + _ -> Nothing + + +-- | Wrap all inlines with an XML tag (given its unqualified name). +wrap :: String -> [Inline] -> FBM Content +wrap tagname inlines = el tagname `liftM` cMapM toXml inlines + +-- " Create a singleton list. +list :: a -> [a] +list = (:[]) + +-- | Convert an 'Inline' to plaintext. +plain :: Inline -> String +plain (Str s) = s +plain (Emph ss) = concat (map plain ss) +plain (Strong ss) = concat (map plain ss) +plain (Strikeout ss) = concat (map plain ss) +plain (Superscript ss) = concat (map plain ss) +plain (Subscript ss) = concat (map plain ss) +plain (SmallCaps ss) = concat (map plain ss) +plain (Quoted _ ss) = concat (map plain ss) +plain (Cite _ ss) = concat (map plain ss) -- FIXME +plain (Code _ s) = s +plain Space = " " +plain LineBreak = "\n" +plain (Math _ s) = s +plain (RawInline _ s) = s +plain (Link text (url,_)) = concat (map plain text ++ [" <", url, ">"]) +plain (Image alt _) = concat (map plain alt) +plain (Note _) = "" -- FIXME + +-- | Create an XML element. +el :: (Node t) + => String -- ^ unqualified element name + -> t -- ^ node contents + -> Content -- ^ XML content +el name cs = Elem $ unode name cs + +-- | Put empty lines around content +spaceBeforeAfter :: [Content] -> [Content] +spaceBeforeAfter cs = + let emptyline = el "empty-line" () + in [emptyline] ++ cs ++ [emptyline] + +-- | Create a plain-text XML content. +txt :: String -> Content +txt s = Text $ CData CDataText s Nothing + +-- | Create an XML attribute with an unqualified name. +uattr :: String -> String -> Text.XML.Light.Attr +uattr name val = Attr (uname name) val + +-- | Create an XML attribute with a qualified name from given namespace. +attr :: (String, String) -> String -> Text.XML.Light.Attr +attr (ns, name) val = Attr (qname ns name) val + +-- | Unqualified name +uname :: String -> QName +uname name = QName name Nothing Nothing + +-- | Qualified name +qname :: String -> String -> QName +qname ns name = QName name Nothing (Just ns) + +-- | Abbreviation for 'concatMap'. +cMap :: (a -> [b]) -> [a] -> [b] +cMap = concatMap + +-- | Monadic equivalent of 'concatMap'. +cMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +cMapM f xs = concat `liftM` mapM f xs
\ No newline at end of file diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index b8474ee3f..c6c4a8fd7 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -32,6 +32,7 @@ Conversion of 'Pandoc' documents to HTML. module Text.Pandoc.Writers.HTML ( writeHtml , writeHtmlString ) where import Text.Pandoc.Definition import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.Templates import Text.Pandoc.Generic import Text.Pandoc.Readers.TeXMath @@ -272,7 +273,7 @@ elementToHtml slideLevel opts (Sec level num id' title' elements) = do -- title slides have no content of their own then filter isSec elements else elements - let header'' = if (writerStrictMarkdown opts || writerSectionDivs opts || + let header'' = if (writerSectionDivs opts || writerSlideVariant opts == S5Slides || slide) then header' else header' ! prefixedId opts id' @@ -378,13 +379,17 @@ blockToHtml _ Null = return mempty blockToHtml opts (Plain lst) = inlineListToHtml opts lst blockToHtml opts (Para [Image txt (s,tit)]) = do img <- inlineToHtml opts (Image txt (s,tit)) - capt <- inlineListToHtml opts txt + let tocapt = if writerHtml5 opts + then H5.figcaption + else H.p ! A.class_ "caption" + capt <- if null txt + then return mempty + else tocapt `fmap` inlineListToHtml opts txt return $ if writerHtml5 opts then H5.figure $ mconcat - [nl opts, img, H5.figcaption capt, nl opts] + [nl opts, img, capt, nl opts] else H.div ! A.class_ "figure" $ mconcat - [nl opts, img, H.p ! A.class_ "caption" $ capt, - nl opts] + [nl opts, img, capt, nl opts] blockToHtml opts (Para lst) = do contents <- inlineListToHtml opts lst return $ H.p contents @@ -392,7 +397,7 @@ blockToHtml _ (RawBlock "html" str) = return $ preEscapedString str blockToHtml _ (RawBlock _ _) = return mempty blockToHtml opts (HorizontalRule) = return $ if writerHtml5 opts then H5.hr else H.hr blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do - let tolhs = writerLiterateHaskell opts && + let tolhs = isEnabled Ext_literate_haskell opts && any (\c -> map toLower c == "haskell") classes && any (\c -> map toLower c == "literate") classes classes' = if tolhs @@ -618,7 +623,7 @@ inlineToHtml opts inline = ! A.src (toValue $ url ++ urlEncode str) ! A.alt (toValue str) ! A.title (toValue str) - let brtag = if writerHtml5 opts then H5.br else H.br + let brtag = if writerHtml5 opts then H5.br else H.br return $ case t of InlineMath -> m DisplayMath -> brtag >> m >> brtag @@ -638,7 +643,7 @@ inlineToHtml opts inline = Left _ -> inlineListToHtml opts (readTeXMath str) >>= return . (H.span ! A.class_ "math") - MathJax _ -> return $ toHtml $ + MathJax _ -> return $ H.span ! A.class_ "math" $ toHtml $ case t of InlineMath -> "\\(" ++ str ++ "\\)" DisplayMath -> "\\[" ++ str ++ "\\]" diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index 7beee2d42..abbbd4d01 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -32,6 +32,7 @@ module Text.Pandoc.Writers.LaTeX ( writeLaTeX ) where import Text.Pandoc.Definition import Text.Pandoc.Generic import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.Templates import Text.Printf ( printf ) import Network.URI ( isAbsoluteURI, unEscapeString ) @@ -265,10 +266,12 @@ blockToLaTeX :: Block -- ^ Block to convert blockToLaTeX Null = return empty blockToLaTeX (Plain lst) = inlineListToLaTeX lst blockToLaTeX (Para [Image txt (src,tit)]) = do - capt <- inlineListToLaTeX txt + capt <- if null txt + then return empty + else (\c -> "\\caption" <> braces c) `fmap` inlineListToLaTeX txt img <- inlineToLaTeX (Image txt (src,tit)) return $ "\\begin{figure}[htbp]" $$ "\\centering" $$ img $$ - ("\\caption{" <> capt <> char '}') $$ "\\end{figure}" + capt $$ "\\end{figure}" blockToLaTeX (Para lst) = do result <- inlineListToLaTeX lst return result @@ -287,7 +290,7 @@ blockToLaTeX (BlockQuote lst) = do blockToLaTeX (CodeBlock (_,classes,keyvalAttr) str) = do opts <- gets stOptions case () of - _ | writerLiterateHaskell opts && "haskell" `elem` classes && + _ | isEnabled Ext_literate_haskell opts && "haskell" `elem` classes && "literate" `elem` classes -> lhsCodeBlock | writerListings opts -> listingsCodeBlock | writerHighlight opts && not (null classes) -> highlightedCodeBlock diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index c481e6c87..bececde25 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -17,9 +17,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | - Module : Text.Pandoc.Writers.Man + Module : Text.Pandoc.Writers.Man Copyright : Copyright (C) 2007-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -32,6 +32,7 @@ module Text.Pandoc.Writers.Man ( writeMan) where import Text.Pandoc.Definition import Text.Pandoc.Templates import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.Readers.TeXMath import Text.Printf ( printf ) import Data.List ( isPrefixOf, intersperse, intercalate ) @@ -44,21 +45,21 @@ data WriterState = WriterState { stNotes :: Notes -- | Convert Pandoc to Man. writeMan :: WriterOptions -> Pandoc -> String -writeMan opts document = evalState (pandocToMan opts document) (WriterState [] False) +writeMan opts document = evalState (pandocToMan opts document) (WriterState [] False) -- | Return groff man representation of document. pandocToMan :: WriterOptions -> Pandoc -> State WriterState String pandocToMan opts (Pandoc (Meta title authors date) blocks) = do titleText <- inlineListToMan opts title authors' <- mapM (inlineListToMan opts) authors - date' <- inlineListToMan opts date + date' <- inlineListToMan opts date let colwidth = if writerWrapText opts then Just $ writerColumns opts else Nothing let render' = render colwidth let (cmdName, rest) = break (== ' ') $ render' titleText let (title', section) = case reverse cmdName of - (')':d:'(':xs) | d `elem` ['0'..'9'] -> + (')':d:'(':xs) | d `elem` ['0'..'9'] -> (text (reverse xs), char d) xs -> (text (reverse xs), doubleQuotes empty) let description = hsep $ @@ -86,7 +87,7 @@ notesToMan :: WriterOptions -> [[Block]] -> State WriterState Doc notesToMan opts notes = if null notes then return empty - else mapM (\(num, note) -> noteToMan opts num note) (zip [1..] notes) >>= + else mapM (\(num, note) -> noteToMan opts num note) (zip [1..] notes) >>= return . (text ".SH NOTES" $$) . vcat -- | Return man representation of a note. @@ -94,7 +95,7 @@ noteToMan :: WriterOptions -> Int -> [Block] -> State WriterState Doc noteToMan opts num note = do contents <- blockListToMan opts note let marker = cr <> text ".SS " <> brackets (text (show num)) - return $ marker $$ contents + return $ marker $$ contents -- | Association list of characters to escape. manEscapes :: [(Char, String)] @@ -104,7 +105,7 @@ manEscapes = [ ('\160', "\\ ") , ('\x2014', "\\[em]") , ('\x2013', "\\[en]") , ('\x2026', "\\&...") - ] ++ backslashEscapes "@\\" + ] ++ backslashEscapes "-@\\" -- | Escape special characters for Man. escapeString :: String -> String @@ -113,7 +114,7 @@ escapeString = escapeStringUsing manEscapes -- | Escape a literal (code) section for Man. escapeCode :: String -> String escapeCode = concat . intersperse "\n" . map escapeLine . lines where - escapeLine codeline = + escapeLine codeline = case escapeStringUsing (manEscapes ++ backslashEscapes "\t ") codeline of a@('.':_) -> "\\&" ++ a b -> b @@ -150,14 +151,14 @@ splitSentences xs = -- | Convert Pandoc block element to man. blockToMan :: WriterOptions -- ^ Options -> Block -- ^ Block element - -> State WriterState Doc + -> State WriterState Doc blockToMan _ Null = return empty -blockToMan opts (Plain inlines) = +blockToMan opts (Plain inlines) = liftM vcat $ mapM (inlineListToMan opts) $ splitSentences inlines blockToMan opts (Para inlines) = do contents <- liftM vcat $ mapM (inlineListToMan opts) $ splitSentences inlines - return $ text ".PP" $$ contents + return $ text ".PP" $$ contents blockToMan _ (RawBlock "man" str) = return $ text str blockToMan _ (RawBlock _ _) = return empty blockToMan _ HorizontalRule = return $ text ".PP" $$ text " * * * * *" @@ -166,7 +167,7 @@ blockToMan opts (Header level inlines) = do let heading = case level of 1 -> ".SH " _ -> ".SS " - return $ text heading <> contents + return $ text heading <> contents blockToMan _ (CodeBlock _ str) = return $ text ".IP" $$ text ".nf" $$ @@ -174,10 +175,10 @@ blockToMan _ (CodeBlock _ str) = return $ text (escapeCode str) $$ text "\\f[]" $$ text ".fi" -blockToMan opts (BlockQuote blocks) = do +blockToMan opts (BlockQuote blocks) = do contents <- blockListToMan opts blocks return $ text ".RS" $$ contents $$ text ".RE" -blockToMan opts (Table caption alignments widths headers rows) = +blockToMan opts (Table caption alignments widths headers rows) = let aligncode AlignLeft = "l" aligncode AlignRight = "r" aligncode AlignCenter = "c" @@ -190,53 +191,53 @@ blockToMan opts (Table caption alignments widths headers rows) = else map (printf "w(%0.2fn)" . (70 *)) widths -- 78n default width - 8n indent = 70n let coldescriptions = text $ intercalate " " - (zipWith (\align width -> aligncode align ++ width) + (zipWith (\align width -> aligncode align ++ width) alignments iwidths) ++ "." colheadings <- mapM (blockListToMan opts) headers - let makeRow cols = text "T{" $$ - (vcat $ intersperse (text "T}@T{") cols) $$ + let makeRow cols = text "T{" $$ + (vcat $ intersperse (text "T}@T{") cols) $$ text "T}" let colheadings' = if all null headers then empty else makeRow colheadings $$ char '_' - body <- mapM (\row -> do + body <- mapM (\row -> do cols <- mapM (blockListToMan opts) row return $ makeRow cols) rows - return $ text ".PP" $$ caption' $$ - text ".TS" $$ text "tab(@);" $$ coldescriptions $$ + return $ text ".PP" $$ caption' $$ + text ".TS" $$ text "tab(@);" $$ coldescriptions $$ colheadings' $$ vcat body $$ text ".TE" blockToMan opts (BulletList items) = do contents <- mapM (bulletListItemToMan opts) items - return (vcat contents) + return (vcat contents) blockToMan opts (OrderedList attribs items) = do - let markers = take (length items) $ orderedListMarkers attribs + let markers = take (length items) $ orderedListMarkers attribs let indent = 1 + (maximum $ map length markers) contents <- mapM (\(num, item) -> orderedListItemToMan opts num indent item) $ - zip markers items + zip markers items return (vcat contents) -blockToMan opts (DefinitionList items) = do +blockToMan opts (DefinitionList items) = do contents <- mapM (definitionListItemToMan opts) items return (vcat contents) -- | Convert bullet list item (list of blocks) to man. bulletListItemToMan :: WriterOptions -> [Block] -> State WriterState Doc bulletListItemToMan _ [] = return empty -bulletListItemToMan opts ((Para first):rest) = +bulletListItemToMan opts ((Para first):rest) = bulletListItemToMan opts ((Plain first):rest) bulletListItemToMan opts ((Plain first):rest) = do - first' <- blockToMan opts (Plain first) + first' <- blockToMan opts (Plain first) rest' <- blockListToMan opts rest let first'' = text ".IP \\[bu] 2" $$ first' let rest'' = if null rest then empty else text ".RS 2" $$ rest' $$ text ".RE" - return (first'' $$ rest'') + return (first'' $$ rest'') bulletListItemToMan opts (first:rest) = do first' <- blockToMan opts first rest' <- blockListToMan opts rest 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 @@ -244,7 +245,7 @@ orderedListItemToMan :: WriterOptions -- ^ options -> [Block] -- ^ list item (list of blocks) -> State WriterState Doc orderedListItemToMan _ _ _ [] = return empty -orderedListItemToMan opts num indent ((Para first):rest) = +orderedListItemToMan opts num indent ((Para first):rest) = orderedListItemToMan opts num indent ((Plain first):rest) orderedListItemToMan opts num indent (first:rest) = do first' <- blockToMan opts first @@ -254,17 +255,17 @@ orderedListItemToMan opts num indent (first:rest) = do let rest'' = if null rest then empty else text ".RS 4" $$ rest' $$ text ".RE" - return $ first'' $$ rest'' + return $ first'' $$ rest'' -- | Convert definition list item (label, list of blocks) to man. definitionListItemToMan :: WriterOptions - -> ([Inline],[[Block]]) + -> ([Inline],[[Block]]) -> State WriterState Doc definitionListItemToMan opts (label, defs) = do labelText <- inlineListToMan opts label - contents <- if null defs + contents <- if null defs then return empty - else liftM vcat $ forM defs $ \blocks -> do + else liftM vcat $ forM defs $ \blocks -> do let (first, rest) = case blocks of ((Para x):y) -> (Plain x,y) (x:y) -> (x,y) @@ -278,7 +279,7 @@ definitionListItemToMan opts (label, defs) = do -- | Convert list of Pandoc block elements to man. blockListToMan :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> State WriterState Doc + -> State WriterState Doc blockListToMan opts blocks = mapM (blockToMan opts) blocks >>= (return . vcat) @@ -292,7 +293,7 @@ inlineListToMan opts lst = mapM (inlineToMan opts) lst >>= (return . hcat) -- | Convert Pandoc inline element to man. inlineToMan :: WriterOptions -> Inline -> State WriterState Doc -inlineToMan opts (Emph lst) = do +inlineToMan opts (Emph lst) = do contents <- inlineListToMan opts lst return $ text "\\f[I]" <> contents <> text "\\f[]" inlineToMan opts (Strong lst) = do @@ -333,16 +334,16 @@ inlineToMan opts (Link txt (src, _)) = do let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src return $ case txt of [Code _ s] - | s == srcSuffix -> char '<' <> text srcSuffix <> char '>' + | s == srcSuffix -> char '<' <> text srcSuffix <> char '>' _ -> linktext <> text " (" <> text src <> char ')' inlineToMan opts (Image alternate (source, tit)) = do - let txt = if (null alternate) || (alternate == [Str ""]) || + let txt = if (null alternate) || (alternate == [Str ""]) || (alternate == [Str source]) -- to prevent autolinks then [Str "image"] else alternate - linkPart <- inlineToMan opts (Link txt (source, tit)) + linkPart <- inlineToMan opts (Link txt (source, tit)) return $ char '[' <> text "IMAGE: " <> linkPart <> char ']' -inlineToMan _ (Note contents) = do +inlineToMan _ (Note contents) = do -- add to notes in state modify $ \st -> st{ stNotes = contents : stNotes st } notes <- liftM stNotes get diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 9cbcaeb47..d88419feb 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TupleSections #-} {- Copyright (C) 2006-2010 John MacFarlane <jgm@berkeley.edu> @@ -18,9 +18,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | - Module : Text.Pandoc.Writers.Markdown + Module : Text.Pandoc.Writers.Markdown Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -35,11 +35,15 @@ import Text.Pandoc.Definition import Text.Pandoc.Generic import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Shared -import Text.Pandoc.Parsing hiding (blankline) -import Text.ParserCombinators.Parsec ( runParser, GenParser ) +import Text.Pandoc.Options +import Text.Pandoc.Parsing hiding (blankline, char, space) import Data.List ( group, isPrefixOf, find, intersperse, transpose ) import Text.Pandoc.Pretty import Control.Monad.State +import qualified Data.Set as Set +import Text.Pandoc.Writers.HTML (writeHtmlString) +import Text.Pandoc.Readers.TeXMath (readTeXMath) +import Text.HTML.TagSoup (renderTags, parseTags, isTagText, Tag(..)) type Notes = [[Block]] type Refs = [([Inline], Target)] @@ -49,7 +53,7 @@ data WriterState = WriterState { stNotes :: Notes -- | Convert Pandoc to Markdown. writeMarkdown :: WriterOptions -> Pandoc -> String -writeMarkdown opts document = +writeMarkdown opts document = evalState (pandocToMarkdown opts document) WriterState{ stNotes = [] , stRefs = [] , stPlain = False } @@ -58,7 +62,9 @@ writeMarkdown opts document = -- pictures, or inline formatting). writePlain :: WriterOptions -> Pandoc -> String writePlain opts document = - evalState (pandocToMarkdown opts{writerStrictMarkdown = True} + evalState (pandocToMarkdown opts{ + writerExtensions = Set.delete Ext_escaped_line_breaks $ + writerExtensions opts } document') WriterState{ stNotes = [] , stRefs = [] , stPlain = True } @@ -81,15 +87,41 @@ plainify = bottomUp go go (Cite _ cits) = SmallCaps cits go x = x +pandocTitleBlock :: Doc -> [Doc] -> Doc -> Doc +pandocTitleBlock tit auths dat = + hang 2 (text "% ") tit <> cr <> + hang 2 (text "% ") (hcat (intersperse (text "; ") auths)) <> cr <> + hang 2 (text "% ") dat <> cr + +mmdTitleBlock :: Doc -> [Doc] -> Doc -> Doc +mmdTitleBlock tit auths dat = + hang 8 (text "Title: ") tit <> cr <> + hang 8 (text "Author: ") (hcat (intersperse (text "; ") auths)) <> cr <> + hang 8 (text "Date: ") dat <> cr + +plainTitleBlock :: Doc -> [Doc] -> Doc -> Doc +plainTitleBlock tit auths dat = + tit <> cr <> + (hcat (intersperse (text "; ") auths)) <> cr <> + dat <> cr + -- | Return markdown representation of document. pandocToMarkdown :: WriterOptions -> Pandoc -> State WriterState String pandocToMarkdown opts (Pandoc (Meta title authors date) blocks) = do title' <- inlineListToMarkdown opts title authors' <- mapM (inlineListToMarkdown opts) authors date' <- inlineListToMarkdown opts date - let titleblock = not $ null title && null authors && null date + isPlain <- gets stPlain + let titleblock = case True of + _ | isPlain -> + plainTitleBlock title' authors' date' + | isEnabled Ext_pandoc_title_block opts -> + pandocTitleBlock title' authors' date' + | isEnabled Ext_mmd_title_block opts -> + mmdTitleBlock title' authors' date' + | otherwise -> empty let headerBlocks = filter isHeaderBlock blocks - let toc = if writerTableOfContents opts + let toc = if writerTableOfContents opts then tableOfContents opts headerBlocks else empty body <- blockListToMarkdown opts blocks @@ -106,11 +138,9 @@ pandocToMarkdown opts (Pandoc (Meta title authors date) blocks) = do let context = writerVariables opts ++ [ ("toc", render colwidth toc) , ("body", main) - , ("title", render colwidth title') - , ("date", render colwidth date') ] ++ - [ ("titleblock", "yes") | titleblock ] ++ - [ ("author", render colwidth a) | a <- authors' ] + [ ("titleblock", render colwidth titleblock) + | not (null title && null authors && null date) ] if writerStandalone opts then return $ renderTemplate context $ writerTemplate opts else return main @@ -119,9 +149,9 @@ pandocToMarkdown opts (Pandoc (Meta title authors date) blocks) = do refsToMarkdown :: WriterOptions -> Refs -> State WriterState Doc refsToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat --- | Return markdown representation of a reference key. -keyToMarkdown :: WriterOptions - -> ([Inline], (String, String)) +-- | Return markdown representation of a reference key. +keyToMarkdown :: WriterOptions + -> ([Inline], (String, String)) -> State WriterState Doc keyToMarkdown opts (label, (src, tit)) = do label' <- inlineListToMarkdown opts label @@ -133,7 +163,7 @@ keyToMarkdown opts (label, (src, tit)) = do -- | Return markdown representation of notes. notesToMarkdown :: WriterOptions -> [[Block]] -> State WriterState Doc -notesToMarkdown opts notes = +notesToMarkdown opts notes = mapM (\(num, note) -> noteToMarkdown opts num note) (zip [1..] notes) >>= return . vsep @@ -142,12 +172,16 @@ noteToMarkdown :: WriterOptions -> Int -> [Block] -> State WriterState Doc noteToMarkdown opts num blocks = do contents <- blockListToMarkdown opts blocks let num' = text $ show num - let marker = text "[^" <> num' <> text "]:" + let marker = if isEnabled Ext_footnotes opts + then text "[^" <> num' <> text "]:" + else text "[" <> num' <> text "]" let markerSize = 4 + offset num' let spacer = case writerTabStop opts - markerSize of n | n > 0 -> text $ replicate n ' ' _ -> text " " - return $ hang (writerTabStop opts) (marker <> spacer) contents + return $ if isEnabled Ext_footnotes opts + then hang (writerTabStop opts) (marker <> spacer) contents + else marker <> spacer <> contents -- | Escape special characters for Markdown. escapeString :: String -> String @@ -155,7 +189,7 @@ escapeString = escapeStringUsing markdownEscapes where markdownEscapes = backslashEscapes "\\`*_$<>#~^" -- | Construct table of contents from list of header blocks. -tableOfContents :: WriterOptions -> [Block] -> Doc +tableOfContents :: WriterOptions -> [Block] -> Doc tableOfContents opts headers = let opts' = opts { writerIgnoreNotes = True } contents = BulletList $ map elementToListItem $ hierarchicalize headers @@ -166,7 +200,7 @@ tableOfContents opts headers = -- | Converts an Element to a list item for a table of contents, elementToListItem :: Element -> [Block] elementToListItem (Blk _) = [] -elementToListItem (Sec _ _ _ headerText subsecs) = [Plain headerText] ++ +elementToListItem (Sec _ _ _ headerText subsecs) = [Plain headerText] ++ if null subsecs then [] else [BulletList $ map elementToListItem subsecs] @@ -188,9 +222,9 @@ attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] <> "=\"" <> text v <> "\"") ks -- | Ordered list start parser for use in Para below. -olMarker :: GenParser Char ParserState Char +olMarker :: Parser [Char] ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker - if delim == Period && + if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && start `elem` [1, 5, 10, 50, 100, 500, 1000])) then spaceChar >> spaceChar @@ -206,7 +240,7 @@ beginsWithOrderedListMarker str = -- | Convert Pandoc block element to markdown. blockToMarkdown :: WriterOptions -- ^ Options -> Block -- ^ Block element - -> State WriterState Doc + -> State WriterState Doc blockToMarkdown _ Null = return empty blockToMarkdown opts (Plain inlines) = do contents <- inlineListToMarkdown opts inlines @@ -215,14 +249,21 @@ blockToMarkdown opts (Para inlines) = do contents <- inlineListToMarkdown opts inlines -- escape if para starts with ordered list marker st <- get - let esc = if (not (writerStrictMarkdown opts)) && + let esc = if isEnabled Ext_all_symbols_escapable opts && not (stPlain st) && beginsWithOrderedListMarker (render Nothing contents) then text "\x200B" -- zero-width space, a hack else empty return $ esc <> contents <> blankline -blockToMarkdown _ (RawBlock f str) - | f == "html" || f == "latex" || f == "tex" || f == "markdown" = do +blockToMarkdown opts (RawBlock f str) + | f == "html" = do + st <- get + if stPlain st + then return empty + else return $ if isEnabled Ext_markdown_attribute opts + then text (addMarkdownAttribute str) <> text "\n" + else text str <> text "\n" + | f == "latex" || f == "tex" || f == "markdown" = do st <- get if stPlain st then return empty @@ -243,88 +284,148 @@ blockToMarkdown opts (Header level inlines) = do contents <> cr <> text (replicate (offset contents) '-') <> blankline -- ghc interprets '#' characters in column 1 as linenum specifiers. - _ | stPlain st || writerLiterateHaskell opts -> + _ | stPlain st || isEnabled Ext_literate_haskell opts -> contents <> blankline _ -> text (replicate level '#') <> space <> contents <> blankline blockToMarkdown opts (CodeBlock (_,classes,_) str) | "haskell" `elem` classes && "literate" `elem` classes && - writerLiterateHaskell opts = + isEnabled Ext_literate_haskell opts = return $ prefixed "> " (text str) <> blankline blockToMarkdown opts (CodeBlock attribs str) = return $ - if writerStrictMarkdown opts || attribs == nullAttr - then nest (writerTabStop opts) (text str) <> blankline - else -- use delimited code block - (tildes <> space <> attrs <> cr <> text str <> - cr <> tildes) <> blankline - where tildes = text "~~~~" - attrs = attrsToMarkdown attribs + case attribs of + x | x /= nullAttr && isEnabled Ext_fenced_code_blocks opts -> + tildes <> space <> attrs <> cr <> text str <> + cr <> tildes <> blankline + (_,(cls:_),_) | isEnabled Ext_backtick_code_blocks opts -> + backticks <> space <> text cls <> cr <> text str <> + cr <> backticks <> blankline + _ -> nest (writerTabStop opts) (text str) <> blankline + where tildes = text $ case [ln | ln <- lines str, all (=='~') ln] of + [] -> "~~~~" + xs -> case maximum $ map length xs of + n | n < 3 -> "~~~~" + | otherwise -> replicate (n+1) '~' + backticks = text "```" + attrs = if isEnabled Ext_fenced_code_attributes opts + then attrsToMarkdown attribs + else empty blockToMarkdown opts (BlockQuote blocks) = do st <- get -- if we're writing literate haskell, put a space before the bird tracks -- so they won't be interpreted as lhs... - let leader = if writerLiterateHaskell opts + let leader = if isEnabled Ext_literate_haskell opts then " > " else if stPlain st then " " else "> " contents <- blockListToMarkdown opts blocks return $ (prefixed leader contents) <> blankline -blockToMarkdown opts (Table caption aligns widths headers rows) = do +blockToMarkdown opts t@(Table caption aligns widths headers rows) = do caption' <- inlineListToMarkdown opts caption - let caption'' = if null caption + let caption'' = if null caption || not (isEnabled Ext_table_captions opts) then empty else blankline <> ": " <> caption' <> blankline - headers' <- mapM (blockListToMarkdown opts) headers + rawHeaders <- mapM (blockListToMarkdown opts) headers + rawRows <- mapM (mapM (blockListToMarkdown opts)) rows + let isSimple = all (==0) widths + (nst,tbl) <- case isSimple of + True | isEnabled Ext_simple_tables opts -> fmap (nest 2,) $ + pandocTable opts (all null headers) aligns widths + rawHeaders rawRows + | isEnabled Ext_pipe_tables opts -> fmap (id,) $ + pipeTable (all null headers) aligns rawHeaders rawRows + | otherwise -> fmap (id,) $ + return $ text $ writeHtmlString def + $ Pandoc (Meta [] [] []) [t] + False | isEnabled Ext_multiline_tables opts -> fmap (nest 2,) $ + pandocTable opts (all null headers) aligns widths + rawHeaders rawRows + | otherwise -> fmap (id,) $ + return $ text $ writeHtmlString def + $ Pandoc (Meta [] [] []) [t] + return $ nst $ tbl $$ blankline $$ caption'' $$ blankline +blockToMarkdown opts (BulletList items) = do + contents <- mapM (bulletListItemToMarkdown opts) items + return $ cat contents <> blankline +blockToMarkdown opts (OrderedList (start,sty,delim) items) = do + let start' = if isEnabled Ext_startnum opts then start else 1 + let sty' = if isEnabled Ext_fancy_lists opts then sty else DefaultStyle + let delim' = if isEnabled Ext_fancy_lists opts then delim else DefaultDelim + let attribs = (start', sty', delim') + let markers = orderedListMarkers attribs + let markers' = map (\m -> if length m < 3 + then m ++ replicate (3 - length m) ' ' + else m) markers + contents <- mapM (\(item, num) -> orderedListItemToMarkdown opts item num) $ + zip markers' items + return $ cat contents <> blankline +blockToMarkdown opts (DefinitionList items) = do + contents <- mapM (definitionListItemToMarkdown opts) items + return $ cat contents <> blankline + +addMarkdownAttribute :: String -> String +addMarkdownAttribute s = + case span isTagText $ reverse $ parseTags s of + (xs,(TagOpen t attrs:rest)) -> + renderTags $ reverse rest ++ (TagOpen t attrs' : reverse xs) + where attrs' = ("markdown","1"):[(x,y) | (x,y) <- attrs, + x /= "markdown"] + _ -> s + +pipeTable :: Bool -> [Alignment] -> [Doc] -> [[Doc]] -> State WriterState Doc +pipeTable headless aligns rawHeaders rawRows = do + let torow cs = nowrap $ text "|" <> + hcat (intersperse (text "|") $ map chomp cs) <> text "|" + let toborder (a, h) = let wid = max (offset h) 3 + in text $ case a of + AlignLeft -> ':':replicate (wid - 1) '-' + AlignCenter -> ':':replicate (wid - 2) '-' ++ ":" + AlignRight -> replicate (wid - 1) '-' ++ ":" + AlignDefault -> replicate wid '-' + let header = if headless then empty else torow rawHeaders + let border = torow $ map toborder $ zip aligns rawHeaders + let body = vcat $ map torow rawRows + return $ header $$ border $$ body + +pandocTable :: WriterOptions -> Bool -> [Alignment] -> [Double] + -> [Doc] -> [[Doc]] -> State WriterState Doc +pandocTable opts headless aligns widths rawHeaders rawRows = do + let isSimple = all (==0) widths let alignHeader alignment = case alignment of AlignLeft -> lblock AlignCenter -> cblock AlignRight -> rblock AlignDefault -> lblock - rawRows <- mapM (mapM (blockListToMarkdown opts)) rows - let isSimple = all (==0) widths let numChars = maximum . map offset - let widthsInChars = - if isSimple - then map ((+2) . numChars) $ transpose (headers' : rawRows) - else map (floor . (fromIntegral (writerColumns opts) *)) widths + let widthsInChars = if isSimple + then map ((+2) . numChars) + $ transpose (rawHeaders : rawRows) + else map + (floor . (fromIntegral (writerColumns opts) *)) + widths let makeRow = hcat . intersperse (lblock 1 (text " ")) . (zipWith3 alignHeader aligns widthsInChars) let rows' = map makeRow rawRows - let head' = makeRow headers' + let head' = makeRow rawHeaders let maxRowHeight = maximum $ map height (head':rows') let underline = cat $ intersperse (text " ") $ map (\width -> text (replicate width '-')) widthsInChars let border = if maxRowHeight > 1 then text (replicate (sum widthsInChars + length widthsInChars - 1) '-') - else if all null headers + else if headless then underline else empty - let head'' = if all null headers + let head'' = if headless then empty else border <> cr <> head' let body = if maxRowHeight > 1 then vsep rows' else vcat rows' - let bottom = if all null headers + let bottom = if headless then underline else border - return $ nest 2 $ head'' $$ underline $$ body $$ - bottom $$ blankline $$ caption'' $$ blankline -blockToMarkdown opts (BulletList items) = do - contents <- mapM (bulletListItemToMarkdown opts) items - return $ cat contents <> blankline -blockToMarkdown opts (OrderedList attribs items) = do - let markers = orderedListMarkers attribs - let markers' = map (\m -> if length m < 3 - then m ++ replicate (3 - length m) ' ' - else m) markers - contents <- mapM (\(item, num) -> orderedListItemToMarkdown opts item num) $ - zip markers' items - return $ cat contents <> blankline -blockToMarkdown opts (DefinitionList items) = do - contents <- mapM (definitionListItemToMarkdown opts) items - return $ cat contents <> blankline + return $ head'' $$ underline $$ body $$ bottom -- | Convert bullet list item (list of blocks) to markdown. bulletListItemToMarkdown :: WriterOptions -> [Block] -> State WriterState Doc @@ -349,32 +450,38 @@ orderedListItemToMarkdown opts marker items = do -- | Convert definition list item (label, list of blocks) to markdown. definitionListItemToMarkdown :: WriterOptions - -> ([Inline],[[Block]]) + -> ([Inline],[[Block]]) -> State WriterState Doc definitionListItemToMarkdown opts (label, defs) = do labelText <- inlineListToMarkdown opts label - let tabStop = writerTabStop opts - st <- get - let leader = if stPlain st then " " else ": " - let sps = case writerTabStop opts - 3 of - n | n > 0 -> text $ replicate n ' ' - _ -> text " " defs' <- mapM (mapM (blockToMarkdown opts)) defs - let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs' - return $ nowrap labelText <> cr <> contents <> cr + if isEnabled Ext_definition_lists opts + then do + let tabStop = writerTabStop opts + st <- get + let leader = if stPlain st then " " else ": " + let sps = case writerTabStop opts - 3 of + n | n > 0 -> text $ replicate n ' ' + _ -> text " " + let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs' + return $ nowrap labelText <> cr <> contents <> cr + else do + return $ nowrap labelText <> text " " <> cr <> + vsep (map vsep defs') <> blankline -- | Convert list of Pandoc block elements to markdown. blockListToMarkdown :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> State WriterState Doc + -> State WriterState Doc blockListToMarkdown opts blocks = mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat -- insert comment between list and indented code block, or the -- code block will be treated as a list continuation paragraph where fixBlocks (b : CodeBlock attr x : rest) - | (writerStrictMarkdown opts || attr == nullAttr) && isListBlock b = + | (not (isEnabled Ext_fenced_code_blocks opts) || attr == nullAttr) + && isListBlock b = b : RawBlock "html" "<!-- -->\n" : CodeBlock attr x : - fixBlocks rest + fixBlocks rest fixBlocks (x : xs) = x : fixBlocks xs fixBlocks [] = [] isListBlock (BulletList _) = True @@ -412,7 +519,7 @@ escapeSpaces x = x -- | Convert Pandoc inline element to markdown. inlineToMarkdown :: WriterOptions -> Inline -> State WriterState Doc -inlineToMarkdown opts (Emph lst) = do +inlineToMarkdown opts (Emph lst) = do contents <- inlineListToMarkdown opts lst return $ "*" <> contents <> "*" inlineToMarkdown opts (Strong lst) = do @@ -420,15 +527,21 @@ inlineToMarkdown opts (Strong lst) = do return $ "**" <> contents <> "**" inlineToMarkdown opts (Strikeout lst) = do contents <- inlineListToMarkdown opts lst - return $ "~~" <> contents <> "~~" + return $ if isEnabled Ext_strikeout opts + then "~~" <> contents <> "~~" + else "<s>" <> contents <> "</s>" inlineToMarkdown opts (Superscript lst) = do let lst' = bottomUp escapeSpaces lst contents <- inlineListToMarkdown opts lst' - return $ "^" <> contents <> "^" + return $ if isEnabled Ext_superscript opts + then "^" <> contents <> "^" + else "<sup>" <> contents <> "</sup>" inlineToMarkdown opts (Subscript lst) = do let lst' = bottomUp escapeSpaces lst contents <- inlineListToMarkdown opts lst' - return $ "~" <> contents <> "~" + return $ if isEnabled Ext_subscript opts + then "~" <> contents <> "~" + else "<sub>" <> contents <> "</sub>" inlineToMarkdown opts (SmallCaps lst) = inlineListToMarkdown opts lst inlineToMarkdown opts (Quoted SingleQuote lst) = do contents <- inlineListToMarkdown opts lst @@ -437,33 +550,46 @@ inlineToMarkdown opts (Quoted DoubleQuote lst) = do contents <- inlineListToMarkdown opts lst return $ "“" <> contents <> "”" inlineToMarkdown opts (Code attr str) = - let tickGroups = filter (\s -> '`' `elem` s) $ group str + let tickGroups = filter (\s -> '`' `elem` s) $ group str longest = if null tickGroups then 0 - else maximum $ map length tickGroups - marker = replicate (longest + 1) '`' + else maximum $ map length tickGroups + marker = replicate (longest + 1) '`' spacer = if (longest == 0) then "" else " " - attrs = if writerStrictMarkdown opts || attr == nullAttr - then empty - else attrsToMarkdown attr + attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr + then attrsToMarkdown attr + else empty in return $ text (marker ++ spacer ++ str ++ spacer ++ marker) <> attrs inlineToMarkdown _ (Str str) = do st <- get if stPlain st then return $ text str else return $ text $ escapeString str -inlineToMarkdown _ (Math InlineMath str) = - return $ "$" <> text str <> "$" -inlineToMarkdown _ (Math DisplayMath str) = - return $ "$$" <> text str <> "$$" -inlineToMarkdown _ (RawInline f str) - | f == "html" || f == "latex" || f == "tex" || f == "markdown" = +inlineToMarkdown opts (Math InlineMath str) + | isEnabled Ext_tex_math_dollars opts = + return $ "$" <> text str <> "$" + | isEnabled Ext_tex_math_single_backslash opts = + return $ "\\(" <> text str <> "\\)" + | isEnabled Ext_tex_math_double_backslash opts = + return $ "\\\\(" <> text str <> "\\\\)" + | otherwise = inlineListToMarkdown opts $ readTeXMath str +inlineToMarkdown opts (Math DisplayMath str) + | isEnabled Ext_tex_math_dollars opts = + return $ "$$" <> text str <> "$$" + | isEnabled Ext_tex_math_single_backslash opts = + return $ "\\[" <> text str <> "\\]" + | isEnabled Ext_tex_math_double_backslash opts = + return $ "\\\\[" <> text str <> "\\\\]" + | otherwise = (\x -> cr <> x <> cr) `fmap` + inlineListToMarkdown opts (readTeXMath str) +inlineToMarkdown opts (RawInline f str) + | f == "html" || f == "markdown" || + (isEnabled Ext_raw_tex opts && (f == "latex" || f == "tex")) = return $ text str inlineToMarkdown _ (RawInline _ _) = return empty -inlineToMarkdown opts (LineBreak) = return $ - if writerStrictMarkdown opts - then " " <> cr - else "\\" <> cr +inlineToMarkdown opts (LineBreak) + | isEnabled Ext_escaped_line_breaks opts = return $ "\\" <> cr + | otherwise = return $ " " <> cr inlineToMarkdown _ Space = return space inlineToMarkdown opts (Cite (c:cs) lst) | writerCiteMethod opts == Citeproc = inlineListToMarkdown opts lst @@ -513,7 +639,7 @@ inlineToMarkdown opts (Link txt (src, tit)) = do then "[]" else "[" <> reftext <> "]" in first <> second - else "[" <> linktext <> "](" <> + else "[" <> linktext <> "](" <> text src <> linktitle <> ")" inlineToMarkdown opts (Image alternate (source, tit)) = do let txt = if null alternate || alternate == [Str source] @@ -522,8 +648,10 @@ inlineToMarkdown opts (Image alternate (source, tit)) = do else alternate linkPart <- inlineToMarkdown opts (Link txt (source, tit)) return $ "!" <> linkPart -inlineToMarkdown _ (Note contents) = do +inlineToMarkdown opts (Note contents) = do modify (\st -> st{ stNotes = contents : stNotes st }) st <- get let ref = show $ (length $ stNotes st) - return $ "[^" <> text ref <> "]" + if isEnabled Ext_footnotes opts + then return $ "[^" <> text ref <> "]" + else return $ "[" <> text ref <> "]" diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index b32c5327d..84d7393c1 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -17,9 +17,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | - Module : Text.Pandoc.Writers.MediaWiki + Module : Text.Pandoc.Writers.MediaWiki Copyright : Copyright (C) 2008-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -31,7 +31,8 @@ MediaWiki: <http://www.mediawiki.org/wiki/MediaWiki> -} module Text.Pandoc.Writers.MediaWiki ( writeMediaWiki ) where import Text.Pandoc.Definition -import Text.Pandoc.Shared +import Text.Pandoc.Options +import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.XML ( escapeStringForXML ) import Data.List ( intersect, intercalate ) @@ -46,9 +47,9 @@ data WriterState = WriterState { -- | Convert Pandoc to MediaWiki. writeMediaWiki :: WriterOptions -> Pandoc -> String -writeMediaWiki opts document = - evalState (pandocToMediaWiki opts document) - (WriterState { stNotes = False, stListLevel = [], stUseTags = False }) +writeMediaWiki opts document = + evalState (pandocToMediaWiki opts document) + (WriterState { stNotes = False, stListLevel = [], stUseTags = False }) -- | Return MediaWiki representation of document. pandocToMediaWiki :: WriterOptions -> Pandoc -> State WriterState String @@ -57,7 +58,7 @@ pandocToMediaWiki opts (Pandoc _ blocks) = do notesExist <- get >>= return . stNotes let notes = if notesExist then "\n<references />" - else "" + else "" let main = body ++ notes let context = writerVariables opts ++ [ ("body", main) ] ++ @@ -70,22 +71,23 @@ pandocToMediaWiki opts (Pandoc _ blocks) = do escapeString :: String -> String escapeString = escapeStringForXML --- | Convert Pandoc block element to MediaWiki. +-- | Convert Pandoc block element to MediaWiki. blockToMediaWiki :: WriterOptions -- ^ Options -> Block -- ^ Block element - -> State WriterState String + -> State WriterState String blockToMediaWiki _ Null = return "" -blockToMediaWiki opts (Plain inlines) = +blockToMediaWiki opts (Plain inlines) = inlineListToMediaWiki opts inlines blockToMediaWiki opts (Para [Image txt (src,tit)]) = do - capt <- inlineListToMediaWiki opts txt + capt <- if null txt + then return "" + else ("|caption " ++) `fmap` inlineListToMediaWiki opts txt let opt = if null txt then "" - else "|alt=" ++ if null tit then capt else tit ++ - "|caption " ++ capt + else "|alt=" ++ if null tit then capt else tit ++ capt return $ "[[Image:" ++ src ++ "|frame|none" ++ opt ++ "]]\n" blockToMediaWiki opts (Para inlines) = do @@ -115,7 +117,7 @@ blockToMediaWiki _ (CodeBlock (_,classes,_) str) = do "javascript", "latex", "lisp", "lua", "matlab", "mirc", "mpasm", "mysql", "nsis", "objc", "ocaml", "ocaml-brief", "oobas", "oracle8", "pascal", "perl", "php", "php-brief", "plsql", "python", "qbasic", "rails", "reg", "robots", "ruby", "sas", "scheme", "sdlbasic", - "smalltalk", "smarty", "sql", "tcl", "", "thinbasic", "tsql", "vb", "vbnet", "vhdl", + "smalltalk", "smarty", "sql", "tcl", "", "thinbasic", "tsql", "vb", "vbnet", "vhdl", "visualfoxpro", "winbatch", "xml", "xpp", "z80"] let (beg, end) = if null at then ("<pre" ++ if null classes then ">" else " class=\"" ++ unwords classes ++ "\">", "</pre>") @@ -124,7 +126,7 @@ blockToMediaWiki _ (CodeBlock (_,classes,_) str) = do blockToMediaWiki opts (BlockQuote blocks) = do contents <- blockListToMediaWiki opts blocks - return $ "<blockquote>" ++ contents ++ "</blockquote>" + return $ "<blockquote>" ++ contents ++ "</blockquote>" blockToMediaWiki opts (Table capt aligns widths headers rows') = do let alignStrings = map alignmentToString aligns @@ -221,7 +223,7 @@ listItemToMediaWiki opts items = do -- | Convert definition list item (label, list of blocks) to MediaWiki. definitionListItemToMediaWiki :: WriterOptions - -> ([Inline],[[Block]]) + -> ([Inline],[[Block]]) -> State WriterState String definitionListItemToMediaWiki opts (label, items) = do labelText <- inlineListToMediaWiki opts label @@ -242,7 +244,7 @@ isSimpleList x = BulletList items -> all isSimpleListItem items OrderedList (num, sty, _) items -> all isSimpleListItem items && num == 1 && sty `elem` [DefaultStyle, Decimal] - DefinitionList items -> all isSimpleListItem $ concatMap snd items + DefinitionList items -> all isSimpleListItem $ concatMap snd items _ -> False -- | True if list item can be handled with the simple wiki syntax. False if @@ -287,8 +289,8 @@ tableRowToMediaWiki opts alignStrings rownum cols' = do 0 -> "header" x | x `rem` 2 == 1 -> "odd" _ -> "even" - cols'' <- sequence $ zipWith - (\alignment item -> tableItemToMediaWiki opts celltype alignment item) + cols'' <- sequence $ zipWith + (\alignment item -> tableItemToMediaWiki opts celltype alignment item) alignStrings cols' return $ "<tr class=\"" ++ rowclass ++ "\">\n" ++ unlines cols'' ++ "</tr>" @@ -313,7 +315,7 @@ tableItemToMediaWiki opts celltype align' item = do -- | Convert list of Pandoc block elements to MediaWiki. blockListToMediaWiki :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> State WriterState String + -> State WriterState String blockListToMediaWiki opts blocks = mapM (blockToMediaWiki opts) blocks >>= return . vcat @@ -325,9 +327,9 @@ inlineListToMediaWiki opts lst = -- | Convert Pandoc inline element to MediaWiki. inlineToMediaWiki :: WriterOptions -> Inline -> State WriterState String -inlineToMediaWiki opts (Emph lst) = do +inlineToMediaWiki opts (Emph lst) = do contents <- inlineListToMediaWiki opts lst - return $ "''" ++ contents ++ "''" + return $ "''" ++ contents ++ "''" inlineToMediaWiki opts (Strong lst) = do contents <- inlineListToMediaWiki opts lst @@ -365,8 +367,8 @@ inlineToMediaWiki _ (Str str) = return $ escapeString str inlineToMediaWiki _ (Math _ str) = return $ "<math>" ++ str ++ "</math>" -- note: str should NOT be escaped -inlineToMediaWiki _ (RawInline "mediawiki" str) = return str -inlineToMediaWiki _ (RawInline "html" str) = return str +inlineToMediaWiki _ (RawInline "mediawiki" str) = return str +inlineToMediaWiki _ (RawInline "html" str) = return str inlineToMediaWiki _ (RawInline _ _) = return "" inlineToMediaWiki _ (LineBreak) = return "<br />\n" @@ -392,7 +394,7 @@ inlineToMediaWiki opts (Image alt (source, tit)) = do else "|" ++ tit return $ "[[Image:" ++ source ++ txt ++ "]]" -inlineToMediaWiki opts (Note contents) = do +inlineToMediaWiki opts (Note contents) = do contents' <- blockListToMediaWiki opts contents modify (\s -> s { stNotes = True }) return $ "<ref>" ++ contents' ++ "</ref>" diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index d2b56cd17..7fb304e86 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Native Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -34,7 +34,7 @@ metadata. -} module Text.Pandoc.Writers.Native ( writeNative ) where -import Text.Pandoc.Shared ( WriterOptions(..) ) +import Text.Pandoc.Options ( WriterOptions(..) ) import Data.List ( intersperse ) import Text.Pandoc.Definition import Text.Pandoc.Pretty @@ -47,17 +47,17 @@ prettyList ds = prettyBlock :: Block -> Doc prettyBlock (BlockQuote blocks) = "BlockQuote" $$ prettyList (map prettyBlock blocks) -prettyBlock (OrderedList attribs blockLists) = +prettyBlock (OrderedList attribs blockLists) = "OrderedList" <> space <> text (show attribs) $$ (prettyList $ map (prettyList . map prettyBlock) blockLists) -prettyBlock (BulletList blockLists) = +prettyBlock (BulletList blockLists) = "BulletList" $$ (prettyList $ map (prettyList . map prettyBlock) blockLists) prettyBlock (DefinitionList items) = "DefinitionList" $$ (prettyList $ map deflistitem items) where deflistitem (term, defs) = "(" <> text (show term) <> "," <> cr <> nest 1 (prettyList $ map (prettyList . map prettyBlock) defs) <> ")" -prettyBlock (Table caption aligns widths header rows) = +prettyBlock (Table caption aligns widths header rows) = "Table " <> text (show caption) <> " " <> text (show aligns) <> " " <> text (show widths) $$ prettyRow header $$ diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 9e3dba98a..f43d0a087 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -36,7 +36,8 @@ import Data.ByteString.Lazy.UTF8 ( fromString ) import Codec.Archive.Zip import Data.Time.Clock.POSIX import Paths_pandoc ( getDataFileName ) -import Text.Pandoc.Shared hiding (Element) +import Text.Pandoc.Options ( WriterOptions(..) ) +import Text.Pandoc.Shared ( stringify ) import Text.Pandoc.ImageSize ( readImageSize, sizeInPoints ) import Text.Pandoc.MIME ( getMimeType ) import Text.Pandoc.Definition @@ -47,16 +48,16 @@ import Control.Monad (liftM) import Network.URI ( unEscapeString ) import Text.Pandoc.XML import Text.Pandoc.Pretty +import qualified Control.Exception as E -- | Produce an ODT file from a Pandoc document. -writeODT :: Maybe FilePath -- ^ Path specified by --reference-odt - -> WriterOptions -- ^ Writer options +writeODT :: WriterOptions -- ^ Writer options -> Pandoc -- ^ Document to convert -> IO B.ByteString -writeODT mbRefOdt opts doc@(Pandoc (Meta title _ _) _) = do +writeODT opts doc@(Pandoc (Meta title _ _) _) = do let datadir = writerUserDataDir opts refArchive <- liftM toArchive $ - case mbRefOdt of + case writerReferenceODT opts of Just f -> B.readFile f Nothing -> do let defaultODT = getDataFileName "reference.odt" >>= B.readFile @@ -128,9 +129,9 @@ transformPic sourceDir entriesRef (Image lab (src,tit)) = do Nothing -> tit entries <- readIORef entriesRef let newsrc = "Pictures/" ++ show (length entries) ++ takeExtension src' - catch (readEntry [] (sourceDir </> src') >>= \entry -> - modifyIORef entriesRef (entry{ eRelativePath = newsrc } :) >> - return (Image lab (newsrc, tit'))) - (\_ -> return (Emph lab)) + E.catch (readEntry [] (sourceDir </> src') >>= \entry -> + modifyIORef entriesRef (entry{ eRelativePath = newsrc } :) >> + return (Image lab (newsrc, tit'))) + (\e -> let _ = (e :: E.SomeException) in return (Emph lab)) transformPic _ _ x = return x diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index a0317511a..027ddfda1 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -31,7 +31,7 @@ Conversion of 'Pandoc' documents to OpenDocument XML. -} module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where import Text.Pandoc.Definition -import Text.Pandoc.Shared +import Text.Pandoc.Options import Text.Pandoc.XML import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Readers.TeXMath diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 7eb943a22..b885a7a40 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -20,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Org Copyright : Copyright (C) 2010 Puneeth Chaganti - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : Puneeth Chaganti <punchagan@gmail.com> Stability : alpha @@ -32,14 +32,15 @@ Org-Mode: <http://orgmode.org> -} module Text.Pandoc.Writers.Org ( writeOrg) where import Text.Pandoc.Definition -import Text.Pandoc.Shared +import Text.Pandoc.Options +import Text.Pandoc.Shared import Text.Pandoc.Pretty import Text.Pandoc.Templates (renderTemplate) import Data.List ( intersect, intersperse, transpose ) import Control.Monad.State import Control.Applicative ( (<$>) ) -data WriterState = +data WriterState = WriterState { stNotes :: [[Block]] , stLinks :: Bool , stImages :: Bool @@ -49,7 +50,7 @@ data WriterState = -- | Convert Pandoc to Org. writeOrg :: WriterOptions -> Pandoc -> String -writeOrg opts document = +writeOrg opts document = let st = WriterState { stNotes = [], stLinks = False, stImages = False, stHasMath = False, stOptions = opts } @@ -82,8 +83,8 @@ pandocToOrg (Pandoc (Meta tit auth dat) blocks) = do -- | Return Org representation of notes. notesToOrg :: [[Block]] -> State WriterState Doc -notesToOrg notes = - mapM (\(num, note) -> noteToOrg num note) (zip [1..] notes) >>= +notesToOrg notes = + mapM (\(num, note) -> noteToOrg num note) (zip [1..] notes) >>= return . vsep -- | Return Org representation of a note. @@ -106,21 +107,24 @@ titleToOrg :: [Inline] -> State WriterState Doc titleToOrg [] = return empty titleToOrg lst = do contents <- inlineListToOrg lst - return $ "#+TITLE: " <> contents + return $ "#+TITLE: " <> contents --- | Convert Pandoc block element to Org. +-- | Convert Pandoc block element to Org. blockToOrg :: Block -- ^ Block element - -> State WriterState Doc + -> State WriterState Doc blockToOrg Null = return empty blockToOrg (Plain inlines) = inlineListToOrg inlines blockToOrg (Para [Image txt (src,tit)]) = do - capt <- inlineListToOrg txt + capt <- if null txt + then return empty + else (\c -> "#+CAPTION: " <> c <> blankline) `fmap` + inlineListToOrg txt img <- inlineToOrg (Image txt (src,tit)) - return $ "#+CAPTION: " <> capt <> blankline <> img + return $ capt <> img blockToOrg (Para inlines) = do contents <- inlineListToOrg inlines return $ contents <> blankline -blockToOrg (RawBlock "html" str) = +blockToOrg (RawBlock "html" str) = return $ blankline $$ "#+BEGIN_HTML" $$ nest 2 (text str) $$ "#+END_HTML" $$ blankline blockToOrg (RawBlock f str) | f == "org" || f == "latex" || f == "tex" = @@ -134,17 +138,17 @@ blockToOrg (Header level inlines) = do blockToOrg (CodeBlock (_,classes,_) str) = do opts <- stOptions <$> get let tabstop = writerTabStop opts - let at = classes `intersect` ["asymptote", "C", "clojure", "css", "ditaa", - "dot", "emacs-lisp", "gnuplot", "haskell", "js", "latex", - "ledger", "lisp", "matlab", "mscgen", "ocaml", "octave", - "oz", "perl", "plantuml", "python", "R", "ruby", "sass", + let at = classes `intersect` ["asymptote", "C", "clojure", "css", "ditaa", + "dot", "emacs-lisp", "gnuplot", "haskell", "js", "latex", + "ledger", "lisp", "matlab", "mscgen", "ocaml", "octave", + "oz", "perl", "plantuml", "python", "R", "ruby", "sass", "scheme", "screen", "sh", "sql", "sqlite"] let (beg, end) = case at of [] -> ("#+BEGIN_EXAMPLE", "#+END_EXAMPLE") (x:_) -> ("#+BEGIN_SRC " ++ x, "#+END_SRC") return $ text beg $$ nest tabstop (text str) $$ text end $$ blankline blockToOrg (BlockQuote blocks) = do - contents <- blockListToOrg blocks + contents <- blockListToOrg blocks return $ blankline $$ "#+BEGIN_QUOTE" $$ nest 2 contents $$ "#+END_QUOTE" $$ blankline blockToOrg (Table caption' _ _ headers rows) = do @@ -155,11 +159,11 @@ blockToOrg (Table caption' _ _ headers rows) = do headers' <- mapM blockListToOrg headers rawRows <- mapM (mapM blockListToOrg) rows let numChars = maximum . map offset - -- FIXME: width is not being used. + -- FIXME: width is not being used. let widthsInChars = map ((+2) . numChars) $ transpose (headers' : rawRows) - -- FIXME: Org doesn't allow blocks with height more than 1. - let hpipeBlocks blocks = hcat [beg, middle, end] + -- FIXME: Org doesn't allow blocks with height more than 1. + let hpipeBlocks blocks = hcat [beg, middle, end] where h = maximum (map height blocks) sep' = lblock 3 $ vcat (map text $ replicate h " | ") beg = lblock 2 $ vcat (map text $ replicate h "| ") @@ -170,7 +174,7 @@ blockToOrg (Table caption' _ _ headers rows) = do rows' <- mapM (\row -> do cols <- mapM blockListToOrg row return $ makeRow cols) rows let border ch = char '|' <> char ch <> - (hcat $ intersperse (char ch <> char '+' <> char ch) $ + (hcat $ intersperse (char ch <> char '+' <> char ch) $ map (\l -> text $ replicate l ch) widthsInChars) <> char ch <> char '|' let body = vcat rows' @@ -186,7 +190,7 @@ blockToOrg (OrderedList (start, _, delim) items) = do let delim' = case delim of TwoParens -> OneParen x -> x - let markers = take (length items) $ orderedListMarkers + let markers = take (length items) $ orderedListMarkers (start, Decimal, delim') let maxMarkerLength = maximum $ map length markers let markers' = map (\m -> let s = maxMarkerLength - length m @@ -222,7 +226,7 @@ definitionListItemToOrg (label, defs) = do -- | Convert list of Pandoc block elements to Org. blockListToOrg :: [Block] -- ^ List of block elements - -> State WriterState Doc + -> State WriterState Doc blockListToOrg blocks = mapM blockToOrg blocks >>= return . vcat -- | Convert list of Pandoc inline elements to Org. @@ -231,19 +235,19 @@ inlineListToOrg lst = mapM inlineToOrg lst >>= return . hcat -- | Convert Pandoc inline element to Org. inlineToOrg :: Inline -> State WriterState Doc -inlineToOrg (Emph lst) = do +inlineToOrg (Emph lst) = do contents <- inlineListToOrg lst return $ "/" <> contents <> "/" inlineToOrg (Strong lst) = do contents <- inlineListToOrg lst return $ "*" <> contents <> "*" -inlineToOrg (Strikeout lst) = do +inlineToOrg (Strikeout lst) = do contents <- inlineListToOrg lst return $ "+" <> contents <> "+" -inlineToOrg (Superscript lst) = do +inlineToOrg (Superscript lst) = do contents <- inlineListToOrg lst return $ "^{" <> contents <> "}" -inlineToOrg (Subscript lst) = do +inlineToOrg (Subscript lst) = do contents <- inlineListToOrg lst return $ "_{" <> contents <> "}" inlineToOrg (SmallCaps lst) = inlineListToOrg lst @@ -276,7 +280,7 @@ inlineToOrg (Link txt (src, _)) = do inlineToOrg (Image _ (source, _)) = do modify $ \s -> s{ stImages = True } return $ "[[" <> text source <> "]]" -inlineToOrg (Note contents) = do +inlineToOrg (Note contents) = do -- add to notes in state notes <- get >>= (return . stNotes) modify $ \st -> st { stNotes = contents:notes } diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index d98079940..5b0b5a414 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -18,9 +18,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | - Module : Text.Pandoc.Writers.RST + Module : Text.Pandoc.Writers.RST Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -32,7 +32,8 @@ reStructuredText: <http://docutils.sourceforge.net/rst.html> -} module Text.Pandoc.Writers.RST ( writeRST) where import Text.Pandoc.Definition -import Text.Pandoc.Shared +import Text.Pandoc.Options +import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Data.List ( isPrefixOf, intersperse, transpose ) import Text.Pandoc.Pretty @@ -42,7 +43,7 @@ import Data.Char (isSpace) type Refs = [([Inline], Target)] -data WriterState = +data WriterState = WriterState { stNotes :: [[Block]] , stLinks :: Refs , stImages :: Refs @@ -52,7 +53,7 @@ data WriterState = -- | Convert Pandoc to RST. writeRST :: WriterOptions -> Pandoc -> String -writeRST opts document = +writeRST opts document = let st = WriterState { stNotes = [], stLinks = [], stImages = [], stHasMath = False, stOptions = opts } @@ -89,8 +90,8 @@ pandocToRST (Pandoc (Meta tit auth dat) blocks) = do refsToRST :: Refs -> State WriterState Doc refsToRST refs = mapM keyToRST refs >>= return . vcat --- | Return RST representation of a reference key. -keyToRST :: ([Inline], (String, String)) +-- | Return RST representation of a reference key. +keyToRST :: ([Inline], (String, String)) -> State WriterState Doc keyToRST (label, (src, _)) = do label' <- inlineListToRST label @@ -101,7 +102,7 @@ keyToRST (label, (src, _)) = do -- | Return RST representation of notes. notesToRST :: [[Block]] -> State WriterState Doc -notesToRST notes = +notesToRST notes = mapM (\(num, note) -> noteToRST num note) (zip [1..] notes) >>= return . vsep @@ -116,8 +117,8 @@ noteToRST num note = do pictRefsToRST :: Refs -> State WriterState Doc pictRefsToRST refs = mapM pictToRST refs >>= return . vcat --- | Return RST representation of a picture substitution reference. -pictToRST :: ([Inline], (String, String)) +-- | Return RST representation of a picture substitution reference. +pictToRST :: ([Inline], (String, String)) -> State WriterState Doc pictToRST (label, (src, _)) = do label' <- inlineListToRST label @@ -135,9 +136,9 @@ titleToRST lst = do let border = text (replicate titleLength '=') return $ border $$ contents $$ border --- | Convert Pandoc block element to RST. +-- | Convert Pandoc block element to RST. blockToRST :: Block -- ^ Block element - -> State WriterState Doc + -> State WriterState Doc blockToRST Null = return empty blockToRST (Plain inlines) = inlineListToRST inlines blockToRST (Para [Image txt (src,tit)]) = do @@ -163,12 +164,12 @@ blockToRST (CodeBlock (_,classes,_) str) = do opts <- stOptions <$> get let tabstop = writerTabStop opts if "haskell" `elem` classes && "literate" `elem` classes && - writerLiterateHaskell opts + isEnabled Ext_literate_haskell opts then return $ prefixed "> " (text str) $$ blankline else return $ "::" $+$ nest tabstop (text str) $$ blankline blockToRST (BlockQuote blocks) = do tabstop <- get >>= (return . writerTabStop . stOptions) - contents <- blockListToRST blocks + contents <- blockListToRST blocks return $ (nest tabstop contents) <> blankline blockToRST (Table caption _ widths headers rows) = do caption' <- inlineListToRST caption @@ -184,7 +185,7 @@ blockToRST (Table caption _ widths headers rows) = do if isSimple then map ((+2) . numChars) $ transpose (headers' : rawRows) else map (floor . (fromIntegral (writerColumns opts) *)) widths - let hpipeBlocks blocks = hcat [beg, middle, end] + let hpipeBlocks blocks = hcat [beg, middle, end] where h = maximum (map height blocks) sep' = lblock 3 $ vcat (map text $ replicate h " | ") beg = lblock 2 $ vcat (map text $ replicate h "| ") @@ -195,7 +196,7 @@ blockToRST (Table caption _ widths headers rows) = do rows' <- mapM (\row -> do cols <- mapM blockListToRST row return $ makeRow cols) rows let border ch = char '+' <> char ch <> - (hcat $ intersperse (char ch <> char '+' <> char ch) $ + (hcat $ intersperse (char ch <> char '+' <> char ch) $ map (\l -> text $ replicate l ch) widthsInChars) <> char ch <> char '+' let body = vcat $ intersperse (border '-') rows' @@ -208,9 +209,9 @@ blockToRST (BulletList items) = do -- ensure that sublists have preceding blank line return $ blankline $$ vcat contents $$ blankline blockToRST (OrderedList (start, style', delim) items) = do - let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim + let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim then take (length items) $ repeat "#." - else take (length items) $ orderedListMarkers + else take (length items) $ orderedListMarkers (start, style', delim) let maxMarkerLength = maximum $ map length markers let markers' = map (\m -> let s = maxMarkerLength - length m @@ -249,7 +250,7 @@ definitionListItemToRST (label, defs) = do -- | Convert list of Pandoc block elements to RST. blockListToRST :: [Block] -- ^ List of block elements - -> State WriterState Doc + -> State WriterState Doc blockListToRST blocks = mapM blockToRST blocks >>= return . vcat -- | Convert list of Pandoc inline elements to RST. @@ -303,19 +304,19 @@ inlineListToRST lst = mapM inlineToRST (insertBS lst) >>= return . hcat -- | Convert Pandoc inline element to RST. inlineToRST :: Inline -> State WriterState Doc -inlineToRST (Emph lst) = do +inlineToRST (Emph lst) = do contents <- inlineListToRST lst return $ "*" <> contents <> "*" inlineToRST (Strong lst) = do contents <- inlineListToRST lst return $ "**" <> contents <> "**" -inlineToRST (Strikeout lst) = do +inlineToRST (Strikeout lst) = do contents <- inlineListToRST lst return $ "[STRIKEOUT:" <> contents <> "]" -inlineToRST (Superscript lst) = do +inlineToRST (Superscript lst) = do contents <- inlineListToRST lst return $ ":sup:`" <> contents <> "`" -inlineToRST (Subscript lst) = do +inlineToRST (Subscript lst) = do contents <- inlineListToRST lst return $ ":sub:`" <> contents <> "`" inlineToRST (SmallCaps lst) = inlineListToRST lst @@ -358,7 +359,7 @@ inlineToRST (Link txt (src, tit)) = do else return $ "`" <> linktext <> " <" <> text src <> ">`_" inlineToRST (Image alternate (source, tit)) = do pics <- get >>= return . stImages - let labelsUsed = map fst pics + let labelsUsed = map fst pics let txt = if null alternate || alternate == [Str ""] || alternate `elem` labelsUsed then [Str $ "image" ++ show (length pics)] @@ -369,7 +370,7 @@ inlineToRST (Image alternate (source, tit)) = do modify $ \st -> st { stImages = pics' } label <- inlineListToRST txt return $ "|" <> label <> "|" -inlineToRST (Note contents) = do +inlineToRST (Note contents) = do -- add to notes in state notes <- get >>= return . stNotes modify $ \st -> st { stNotes = contents:notes } diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 4e7c2a7cd..1919eb3f2 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -19,16 +19,17 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.RTF Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha + Stability : alpha Portability : portable Conversion of 'Pandoc' documents to RTF (rich text format). -} module Text.Pandoc.Writers.RTF ( writeRTF, rtfEmbedImage ) where import Text.Pandoc.Definition +import Text.Pandoc.Options import Text.Pandoc.Shared import Text.Pandoc.Readers.TeXMath import Text.Pandoc.Templates (renderTemplate) @@ -38,6 +39,7 @@ import System.FilePath ( takeExtension ) import qualified Data.ByteString as B import Text.Printf ( printf ) import Network.URI ( isAbsoluteURI, unEscapeString ) +import qualified Control.Exception as E -- | Convert Image inlines into a raw RTF embedded image, read from a file. -- If file not found or filetype not jpeg or png, leave the inline unchanged. @@ -47,7 +49,8 @@ rtfEmbedImage x@(Image _ (src,_)) = do if ext `elem` [".jpg",".jpeg",".png"] && not (isAbsoluteURI src) then do let src' = unEscapeString src - imgdata <- catch (B.readFile src') (\_ -> return B.empty) + imgdata <- E.catch (B.readFile src') + (\e -> let _ = (e :: E.SomeException) in return B.empty) let bytes = map (printf "%02x") $ B.unpack imgdata let filetype = case ext of ".jpg" -> "\\jpegblip" @@ -63,7 +66,7 @@ rtfEmbedImage x = return x -- | Convert Pandoc to a string in rich text format. writeRTF :: WriterOptions -> Pandoc -> String -writeRTF options (Pandoc (Meta title authors date) blocks) = +writeRTF options (Pandoc (Meta title authors date) blocks) = let titletext = inlineListToRTF title authorstext = map inlineListToRTF authors datetext = inlineListToRTF date @@ -82,11 +85,11 @@ writeRTF options (Pandoc (Meta title authors date) blocks) = else body -- | Construct table of contents from list of header blocks. -tableOfContents :: [Block] -> String +tableOfContents :: [Block] -> String tableOfContents headers = let contentsTree = hierarchicalize headers - in concatMap (blockToRTF 0 AlignDefault) $ - [Header 1 [Str "Contents"], + in concatMap (blockToRTF 0 AlignDefault) $ + [Header 1 [Str "Contents"], BulletList (map elementToListItem contentsTree)] elementToListItem :: Element -> [Block] @@ -100,7 +103,7 @@ elementToListItem (Sec _ _ _ sectext subsecs) = [Plain sectext] ++ handleUnicode :: String -> String handleUnicode [] = [] handleUnicode (c:cs) = - if ord c > 127 + if ord c > 127 then '\\':'u':(show (ord c)) ++ "?" ++ handleUnicode cs else c:(handleUnicode cs) @@ -130,32 +133,32 @@ rtfParSpaced :: Int -- ^ space after (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment -> String -- ^ string with content - -> String -rtfParSpaced spaceAfter indent firstLineIndent alignment content = + -> String +rtfParSpaced spaceAfter indent firstLineIndent alignment content = let alignString = case alignment of AlignLeft -> "\\ql " AlignRight -> "\\qr " AlignCenter -> "\\qc " AlignDefault -> "\\ql " in "{\\pard " ++ alignString ++ - "\\f0 \\sa" ++ (show spaceAfter) ++ " \\li" ++ (show indent) ++ + "\\f0 \\sa" ++ (show spaceAfter) ++ " \\li" ++ (show indent) ++ " \\fi" ++ (show firstLineIndent) ++ " " ++ content ++ "\\par}\n" --- | Default paragraph. +-- | Default paragraph. rtfPar :: Int -- ^ block indent (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment -> String -- ^ string with content - -> String -rtfPar = rtfParSpaced 180 + -> String +rtfPar = rtfParSpaced 180 -- | Compact paragraph (e.g. for compact list items). rtfCompact :: Int -- ^ block indent (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment -> String -- ^ string with content - -> String -rtfCompact = rtfParSpaced 0 + -> String +rtfCompact = rtfParSpaced 0 -- number of twips to indent indentIncrement :: Int @@ -172,7 +175,7 @@ bulletMarker indent = case indent `mod` 720 of -- | Returns appropriate (list of) ordered list markers for indent level. orderedMarkers :: Int -> ListAttributes -> [String] -orderedMarkers indent (start, style, delim) = +orderedMarkers indent (start, style, delim) = if style == DefaultStyle && delim == DefaultDelim then case indent `mod` 720 of 0 -> orderedListMarkers (start, Decimal, Period) @@ -185,30 +188,30 @@ blockToRTF :: Int -- ^ indent level -> Block -- ^ block to convert -> String blockToRTF _ _ Null = "" -blockToRTF indent alignment (Plain lst) = +blockToRTF indent alignment (Plain lst) = rtfCompact indent 0 alignment $ inlineListToRTF lst -blockToRTF indent alignment (Para lst) = +blockToRTF indent alignment (Para lst) = rtfPar indent 0 alignment $ inlineListToRTF lst -blockToRTF indent alignment (BlockQuote lst) = - concatMap (blockToRTF (indent + indentIncrement) alignment) lst +blockToRTF indent alignment (BlockQuote lst) = + concatMap (blockToRTF (indent + indentIncrement) alignment) lst blockToRTF indent _ (CodeBlock _ str) = rtfPar indent 0 AlignLeft ("\\f1 " ++ (codeStringToRTF str)) blockToRTF _ _ (RawBlock "rtf" str) = str blockToRTF _ _ (RawBlock _ _) = "" -blockToRTF indent alignment (BulletList lst) = spaceAtEnd $ +blockToRTF indent alignment (BulletList lst) = spaceAtEnd $ concatMap (listItemToRTF alignment indent (bulletMarker indent)) lst -blockToRTF indent alignment (OrderedList attribs lst) = spaceAtEnd $ concat $ +blockToRTF indent alignment (OrderedList attribs lst) = spaceAtEnd $ concat $ zipWith (listItemToRTF alignment indent) (orderedMarkers indent attribs) lst -blockToRTF indent alignment (DefinitionList lst) = spaceAtEnd $ +blockToRTF indent alignment (DefinitionList lst) = spaceAtEnd $ concatMap (definitionListItemToRTF alignment indent) lst -blockToRTF indent _ HorizontalRule = +blockToRTF indent _ HorizontalRule = rtfPar indent 0 AlignCenter "\\emdash\\emdash\\emdash\\emdash\\emdash" blockToRTF indent alignment (Header level lst) = rtfPar indent 0 alignment $ "\\b \\fs" ++ (show (40 - (level * 4))) ++ " " ++ inlineListToRTF lst -blockToRTF indent alignment (Table caption aligns sizes headers rows) = +blockToRTF indent alignment (Table caption aligns sizes headers rows) = (if all null headers then "" - else tableRowToRTF True indent aligns sizes headers) ++ + else tableRowToRTF True indent aligns sizes headers) ++ concatMap (tableRowToRTF False indent aligns sizes) rows ++ rtfPar indent 0 alignment (inlineListToRTF caption) @@ -230,7 +233,7 @@ tableRowToRTF header indent aligns sizes' cols = end = "}\n\\intbl\\row}\n" in start ++ columns ++ end -tableItemToRTF :: Int -> Alignment -> [Block] -> String +tableItemToRTF :: Int -> Alignment -> [Block] -> String tableItemToRTF indent alignment item = let contents = concatMap (blockToRTF indent alignment) item in "{\\intbl " ++ contents ++ "\\cell}\n" @@ -238,7 +241,7 @@ tableItemToRTF indent alignment item = -- | Ensure that there's the same amount of space after compact -- lists as after regular lists. spaceAtEnd :: String -> String -spaceAtEnd str = +spaceAtEnd str = if isSuffixOf "\\par}\n" str then (take ((length str) - 6) str) ++ "\\sa180\\par}\n" else str @@ -249,10 +252,10 @@ listItemToRTF :: Alignment -- ^ alignment -> String -- ^ list start marker -> [Block] -- ^ list item (list of blocks) -> [Char] -listItemToRTF alignment indent marker [] = - rtfCompact (indent + listIncrement) (0 - listIncrement) alignment - (marker ++ "\\tx" ++ (show listIncrement) ++ "\\tab ") -listItemToRTF alignment indent marker list = +listItemToRTF alignment indent marker [] = + rtfCompact (indent + listIncrement) (0 - listIncrement) alignment + (marker ++ "\\tx" ++ (show listIncrement) ++ "\\tab ") +listItemToRTF alignment indent marker list = let (first:rest) = map (blockToRTF (indent + listIncrement) alignment) list listMarker = "\\fi" ++ show (0 - listIncrement) ++ " " ++ marker ++ "\\tx" ++ show listIncrement ++ "\\tab" @@ -275,7 +278,7 @@ definitionListItemToRTF alignment indent (label, defs) = let labelText = blockToRTF indent alignment (Plain label) itemsText = concatMap (blockToRTF (indent + listIncrement) alignment) $ concat defs - in labelText ++ itemsText + in labelText ++ itemsText -- | Convert list of inline items to RTF. inlineListToRTF :: [Inline] -- ^ list of inlines to convert @@ -291,9 +294,9 @@ inlineToRTF (Strikeout lst) = "{\\strike " ++ (inlineListToRTF lst) ++ "}" inlineToRTF (Superscript lst) = "{\\super " ++ (inlineListToRTF lst) ++ "}" inlineToRTF (Subscript lst) = "{\\sub " ++ (inlineListToRTF lst) ++ "}" inlineToRTF (SmallCaps lst) = "{\\scaps " ++ (inlineListToRTF lst) ++ "}" -inlineToRTF (Quoted SingleQuote lst) = +inlineToRTF (Quoted SingleQuote lst) = "\\u8216'" ++ (inlineListToRTF lst) ++ "\\u8217'" -inlineToRTF (Quoted DoubleQuote lst) = +inlineToRTF (Quoted DoubleQuote lst) = "\\u8220\"" ++ (inlineListToRTF lst) ++ "\\u8221\"" inlineToRTF (Code _ str) = "{\\f1 " ++ (codeStringToRTF str) ++ "}" inlineToRTF (Str str) = stringToRTF str @@ -303,11 +306,11 @@ inlineToRTF (RawInline "rtf" str) = str inlineToRTF (RawInline _ _) = "" inlineToRTF (LineBreak) = "\\line " inlineToRTF Space = " " -inlineToRTF (Link text (src, _)) = - "{\\field{\\*\\fldinst{HYPERLINK \"" ++ (codeStringToRTF src) ++ +inlineToRTF (Link text (src, _)) = + "{\\field{\\*\\fldinst{HYPERLINK \"" ++ (codeStringToRTF src) ++ "\"}}{\\fldrslt{\\ul\n" ++ (inlineListToRTF text) ++ "\n}}}\n" -inlineToRTF (Image _ (source, _)) = - "{\\cf1 [image: " ++ source ++ "]\\cf0}" +inlineToRTF (Image _ (source, _)) = + "{\\cf1 [image: " ++ source ++ "]\\cf0}" inlineToRTF (Note contents) = - "{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " ++ + "{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " ++ (concatMap (blockToRTF 0 AlignDefault) contents) ++ "}" diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index 6bb782899..40e76c615 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -19,16 +19,17 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Texinfo Copyright : Copyright (C) 2008-2010 John MacFarlane and Peter Wang - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha + Stability : alpha Portability : portable Conversion of 'Pandoc' format into Texinfo. -} module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where import Text.Pandoc.Definition +import Text.Pandoc.Options import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Printf ( printf ) @@ -40,7 +41,7 @@ import Text.Pandoc.Pretty import Network.URI ( isAbsoluteURI, unEscapeString ) import System.FilePath -data WriterState = +data WriterState = WriterState { stStrikeout :: Bool -- document contains strikeout , stSuperscript :: Bool -- document contains superscript , stSubscript :: Bool -- document contains subscript @@ -53,8 +54,8 @@ data WriterState = -- | Convert Pandoc to Texinfo. writeTexinfo :: WriterOptions -> Pandoc -> String -writeTexinfo options document = - evalState (pandocToTexinfo options $ wrapTop document) $ +writeTexinfo options document = + evalState (pandocToTexinfo options $ wrapTop document) $ WriterState { stStrikeout = False, stSuperscript = False, stSubscript = False } -- | Add a "Top" node around the document, needed by Texinfo. @@ -116,10 +117,12 @@ blockToTexinfo (Plain lst) = inlineListToTexinfo lst blockToTexinfo (Para [Image txt (src,tit)]) = do - capt <- inlineListToTexinfo txt + capt <- if null txt + then return empty + else (\c -> text "@caption" <> braces c) `fmap` + inlineListToTexinfo txt img <- inlineToTexinfo (Image txt (src,tit)) - return $ text "@float" $$ img $$ (text "@caption{" <> capt <> char '}') $$ - text "@end float" + return $ text "@float" $$ img $$ capt $$ text "@end float" blockToTexinfo (Para lst) = inlineListToTexinfo lst -- this is handled differently from Plain in blockListToTexinfo @@ -217,7 +220,7 @@ blockToTexinfo (Table caption aligns widths heads rows) = do else return $ "@columnfractions " ++ concatMap (printf "%.2f ") widths let tableBody = text ("@multitable " ++ colDescriptors) $$ headers $$ - vcat rowsText $$ + vcat rowsText $$ text "@end multitable" return $ if isEmpty captionText then tableBody <> blankline @@ -241,7 +244,7 @@ tableAnyRowToTexinfo :: String -> [[Block]] -> State WriterState Doc tableAnyRowToTexinfo itemtype aligns cols = - zipWithM alignedBlock aligns cols >>= + zipWithM alignedBlock aligns cols >>= return . (text itemtype $$) . foldl (\row item -> row $$ (if isEmpty row then empty else text " @tab ") <> item) empty @@ -358,8 +361,8 @@ inlineToTexinfo :: Inline -- ^ Inline to convert inlineToTexinfo (Emph lst) = inlineListToTexinfo lst >>= return . inCmd "emph" -inlineToTexinfo (Strong lst) = - inlineListToTexinfo lst >>= return . inCmd "strong" +inlineToTexinfo (Strong lst) = + inlineListToTexinfo lst >>= return . inCmd "strong" inlineToTexinfo (Strikeout lst) = do modify $ \st -> st{ stStrikeout = True } diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index 26d5ec6d7..5f3bb6bcd 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Textile Copyright : Copyright (C) 2010 John MacFarlane - License : GNU GPL, version 2 or above + License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> Stability : alpha @@ -31,7 +31,8 @@ Textile: <http://thresholdstate.com/articles/4312/the-textile-reference-manual> -} module Text.Pandoc.Writers.Textile ( writeTextile ) where import Text.Pandoc.Definition -import Text.Pandoc.Shared +import Text.Pandoc.Options +import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.XML ( escapeStringForXML ) import Data.List ( intercalate ) @@ -46,9 +47,9 @@ data WriterState = WriterState { -- | Convert Pandoc to Textile. writeTextile :: WriterOptions -> Pandoc -> String -writeTextile opts document = - evalState (pandocToTextile opts document) - (WriterState { stNotes = [], stListLevel = [], stUseTags = False }) +writeTextile opts document = + evalState (pandocToTextile opts document) + (WriterState { stNotes = [], stListLevel = [], stUseTags = False }) -- | Return Textile representation of document. pandocToTextile :: WriterOptions -> Pandoc -> State WriterState String @@ -90,14 +91,14 @@ escapeCharForTextile x = case x of escapeStringForTextile :: String -> String escapeStringForTextile = concatMap escapeCharForTextile --- | Convert Pandoc block element to Textile. +-- | Convert Pandoc block element to Textile. blockToTextile :: WriterOptions -- ^ Options -> Block -- ^ Block element - -> State WriterState String + -> State WriterState String blockToTextile _ Null = return "" -blockToTextile opts (Plain inlines) = +blockToTextile opts (Plain inlines) = inlineListToTextile opts inlines blockToTextile opts (Para [Image txt (src,tit)]) = do @@ -236,7 +237,7 @@ listItemToTextile opts items = do -- | Convert definition list item (label, list of blocks) to Textile. definitionListItemToTextile :: WriterOptions - -> ([Inline],[[Block]]) + -> ([Inline],[[Block]]) -> State WriterState String definitionListItemToTextile opts (label, items) = do labelText <- inlineListToTextile opts label @@ -294,8 +295,8 @@ tableRowToTextile opts alignStrings rownum cols' = do 0 -> "header" x | x `rem` 2 == 1 -> "odd" _ -> "even" - cols'' <- sequence $ zipWith - (\alignment item -> tableItemToTextile opts celltype alignment item) + cols'' <- sequence $ zipWith + (\alignment item -> tableItemToTextile opts celltype alignment item) alignStrings cols' return $ "<tr class=\"" ++ rowclass ++ "\">\n" ++ unlines cols'' ++ "</tr>" @@ -320,7 +321,7 @@ tableItemToTextile opts celltype align' item = do -- | Convert list of Pandoc block elements to Textile. blockListToTextile :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> State WriterState String + -> State WriterState String blockListToTextile opts blocks = mapM (blockToTextile opts) blocks >>= return . vcat @@ -332,11 +333,11 @@ inlineListToTextile opts lst = -- | Convert Pandoc inline element to Textile. inlineToTextile :: WriterOptions -> Inline -> State WriterState String -inlineToTextile opts (Emph lst) = do +inlineToTextile opts (Emph lst) = do contents <- inlineListToTextile opts lst return $ if '_' `elem` contents then "<em>" ++ contents ++ "</em>" - else "_" ++ contents ++ "_" + else "_" ++ contents ++ "_" inlineToTextile opts (Strong lst) = do contents <- inlineListToTextile opts lst @@ -377,7 +378,7 @@ inlineToTextile opts (Cite _ lst) = inlineListToTextile opts lst inlineToTextile _ (Code _ str) = return $ if '@' `elem` str then "<tt>" ++ escapeStringForXML str ++ "</tt>" - else "@" ++ str ++ "@" + else "@" ++ str ++ "@" inlineToTextile _ (Str str) = return $ escapeStringForTextile str |