diff options
author | fiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b> | 2009-01-24 20:00:26 +0000 |
---|---|---|
committer | fiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b> | 2009-01-24 20:00:26 +0000 |
commit | 42aca57dee8d88afa5fac512aeb1198102908865 (patch) | |
tree | 1c6a98bd226f4fffde6768010715bc1d80e5d168 /src/Text/Pandoc/Writers | |
parent | 39e8d8486693029abfef84c45e85416f7c775280 (diff) |
Moved all haskell source to src subdirectory.
git-svn-id: https://pandoc.googlecode.com/svn/trunk@1528 788f1e2b-df1e-0410-8736-df70ead52e1b
Diffstat (limited to 'src/Text/Pandoc/Writers')
-rw-r--r-- | src/Text/Pandoc/Writers/ConTeXt.hs | 302 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/Docbook.hs | 262 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/HTML.hs | 557 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/LaTeX.hs | 331 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/Man.hs | 301 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/Markdown.hs | 396 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/MediaWiki.hs | 396 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/OpenDocument.hs | 568 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/RST.hs | 346 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/RTF.hs | 291 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/S5.hs | 157 | ||||
-rw-r--r-- | src/Text/Pandoc/Writers/Texinfo.hs | 474 |
12 files changed, 4381 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs new file mode 100644 index 000000000..014751968 --- /dev/null +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -0,0 +1,302 @@ +{- +Copyright (C) 2007-8 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.ConTeXt + Copyright : Copyright (C) 2007-8 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' format into ConTeXt. +-} +module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Printf ( printf ) +import Data.List ( isSuffixOf, intercalate ) +import Control.Monad.State +import Text.PrettyPrint.HughesPJ hiding ( Str ) + +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]"] + +-- | Convert Pandoc to ConTeXt. +writeConTeXt :: WriterOptions -> Pandoc -> String +writeConTeXt options document = + let defaultWriterState = WriterState { stNextRef = 1 + , stOrderedListLevel = 0 + , stOptions = options + } + in render $ + evalState (pandocToConTeXt options document) defaultWriterState + +pandocToConTeXt :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToConTeXt options (Pandoc meta blocks) = do + main <- blockListToConTeXt blocks + let before = if null (writerIncludeBefore options) + then empty + else text $ writerIncludeBefore options + let after = if null (writerIncludeAfter options) + then empty + else text $ writerIncludeAfter options + let body = before $$ main $$ after + head' <- if writerStandalone options + then contextHeader options meta + else return empty + let toc = if writerTableOfContents options + then text "\\placecontent\n" + else empty + let foot = if writerStandalone options + then text "\\stoptext\n" + else empty + return $ head' $$ toc $$ body $$ foot + +-- | Insert bibliographic information into ConTeXt header. +contextHeader :: WriterOptions -- ^ Options, including ConTeXt header + -> Meta -- ^ Meta with bibliographic information + -> State WriterState Doc +contextHeader options (Meta title authors date) = do + titletext <- if null title + then return empty + else inlineListToConTeXt title + let authorstext = if null authors + then "" + else if length authors == 1 + then stringToConTeXt $ head authors + else stringToConTeXt $ (intercalate ", " $ + init authors) ++ " & " ++ last authors + let datetext = if date == "" + then "" + else stringToConTeXt date + let titleblock = text "\\doctitle{" <> titletext <> char '}' $$ + text ("\\author{" ++ authorstext ++ "}") $$ + text ("\\date{" ++ datetext ++ "}") + let header = text $ writerHeader options + return $ header $$ titleblock $$ text "\\starttext\n\\maketitle\n" + +-- escape things as needed for ConTeXt + +escapeCharForConTeXt :: Char -> String +escapeCharForConTeXt ch = + case ch of + '{' -> "\\letteropenbrace{}" + '}' -> "\\letterclosebrace{}" + '\\' -> "\\letterbackslash{}" + '$' -> "\\$" + '|' -> "\\letterbar{}" + '^' -> "\\letterhat{}" + '%' -> "\\%" + '~' -> "\\lettertilde{}" + '&' -> "\\&" + '#' -> "\\#" + '<' -> "\\letterless{}" + '>' -> "\\lettermore{}" + '_' -> "\\letterunderscore{}" + '\160' -> "~" + x -> [x] + +-- | Escape string for ConTeXt +stringToConTeXt :: String -> String +stringToConTeXt = concatMap escapeCharForConTeXt + +-- | Convert Pandoc block element to ConTeXt. +blockToConTeXt :: Block + -> State WriterState BlockWrapper +blockToConTeXt Null = return $ Reg empty +blockToConTeXt (Plain lst) = do + st <- get + let options = stOptions st + contents <- wrapTeXIfNeeded options False inlineListToConTeXt lst + return $ Reg contents +blockToConTeXt (Para lst) = do + st <- get + let options = stOptions st + contents <- wrapTeXIfNeeded options False inlineListToConTeXt lst + return $ Pad contents +blockToConTeXt (BlockQuote lst) = do + contents <- blockListToConTeXt lst + return $ Pad $ text "\\startblockquote" $$ contents $$ text "\\stopblockquote" +blockToConTeXt (CodeBlock _ str) = + return $ Reg $ text $ "\\starttyping\n" ++ str ++ "\n\\stoptyping\n" + -- \n because \stoptyping can't have anything after it, inc. } +blockToConTeXt (RawHtml _) = return $ Reg empty +blockToConTeXt (BulletList lst) = do + contents <- mapM listItemToConTeXt lst + return $ Pad $ text "\\startitemize" $$ vcat contents $$ text "\\stopitemize" +blockToConTeXt (OrderedList (start, style', delim) lst) = do + st <- get + let level = stOrderedListLevel st + put $ st {stOrderedListLevel = level + 1} + contents <- mapM listItemToConTeXt lst + put $ st {stOrderedListLevel = level} + let start' = if start == 1 then "" else "start=" ++ show start + let delim' = case delim of + DefaultDelim -> "" + Period -> "stopper=." + OneParen -> "stopper=)" + TwoParens -> "left=(,stopper=)" + 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" + else "" + let specs2Items = filter (not . null) [start', delim', width''] + let specs2 = if null specs2Items + then "" + else "[" ++ intercalate "," specs2Items ++ "]" + let style'' = case style' of + DefaultStyle -> orderedListStyles !! level + Decimal -> "[n]" + LowerRoman -> "[r]" + UpperRoman -> "[R]" + LowerAlpha -> "[a]" + UpperAlpha -> "[A]" + let specs = style'' ++ specs2 + return $ Pad $ text ("\\startitemize" ++ specs) $$ vcat contents $$ + text "\\stopitemize" +blockToConTeXt (DefinitionList lst) = + mapM defListItemToConTeXt lst >>= return . Pad . wrappedBlocksToDoc +blockToConTeXt HorizontalRule = return $ Pad $ text "\\thinrule" +blockToConTeXt (Header level lst) = do + contents <- inlineListToConTeXt lst + st <- get + let opts = stOptions st + let base = if writerNumberSections opts then "section" else "subject" + return $ Pad $ if level >= 1 && level <= 5 + then char '\\' <> text (concat (replicate (level - 1) "sub")) <> + text base <> char '{' <> contents <> char '}' + else contents +blockToConTeXt (Table caption aligns widths heads rows) = do + let colWidths = map printDecimal widths + let colDescriptor colWidth alignment = (case alignment of + AlignLeft -> 'l' + AlignRight -> 'r' + AlignCenter -> 'c' + AlignDefault -> 'l'): + "p(" ++ colWidth ++ "\\textwidth)|" + let colDescriptors = "|" ++ (concat $ + zipWith colDescriptor colWidths aligns) + headers <- tableRowToConTeXt heads + captionText <- inlineListToConTeXt caption + let captionText' = if null caption then text "none" else captionText + rows' <- mapM tableRowToConTeXt rows + return $ Pad $ text "\\placetable[here]{" <> captionText' <> char '}' $$ + text "\\starttable[" <> text colDescriptors <> char ']' $$ + text "\\HL" $$ headers $$ text "\\HL" $$ + vcat rows' $$ text "\\HL\n\\stoptable" + +printDecimal :: Double -> String +printDecimal = printf "%.2f" + +tableRowToConTeXt :: [[Block]] -> State WriterState Doc +tableRowToConTeXt cols = do + cols' <- mapM blockListToConTeXt cols + return $ (vcat (map (text "\\NC " <>) cols')) $$ + text "\\NC\\AR" + +listItemToConTeXt :: [Block] -> State WriterState Doc +listItemToConTeXt list = blockListToConTeXt list >>= + return . (text "\\item" $$) . (nest 2) + +defListItemToConTeXt :: ([Inline], [Block]) -> State WriterState BlockWrapper +defListItemToConTeXt (term, def) = do + term' <- inlineListToConTeXt term + def' <- blockListToConTeXt def + return $ Pad $ text "\\startdescr{" <> term' <> char '}' $$ def' $$ text "\\stopdescr" + +-- | Convert list of block elements to ConTeXt. +blockListToConTeXt :: [Block] -> State WriterState Doc +blockListToConTeXt lst = mapM blockToConTeXt lst >>= return . wrappedBlocksToDoc + +-- | Convert list of inline elements to ConTeXt. +inlineListToConTeXt :: [Inline] -- ^ Inlines to convert + -> State WriterState Doc +inlineListToConTeXt lst = mapM inlineToConTeXt lst >>= return . hcat + +-- | Convert inline element to ConTeXt +inlineToConTeXt :: Inline -- ^ Inline to convert + -> State WriterState Doc +inlineToConTeXt (Emph lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\em " <> contents <> char '}' +inlineToConTeXt (Strong lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\bf " <> contents <> char '}' +inlineToConTeXt (Strikeout lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\overstrikes{" <> contents <> char '}' +inlineToConTeXt (Superscript lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\high{" <> contents <> char '}' +inlineToConTeXt (Subscript lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\low{" <> contents <> char '}' +inlineToConTeXt (SmallCaps lst) = do + contents <- inlineListToConTeXt lst + return $ text "{\\sc " <> contents <> char '}' +inlineToConTeXt (Code str) = return $ text $ "\\type{" ++ str ++ "}" +inlineToConTeXt (Quoted SingleQuote lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\quote{" <> contents <> char '}' +inlineToConTeXt (Quoted DoubleQuote lst) = do + contents <- inlineListToConTeXt lst + return $ text "\\quotation{" <> contents <> char '}' +inlineToConTeXt (Cite _ lst) = inlineListToConTeXt lst +inlineToConTeXt Apostrophe = return $ char '\'' +inlineToConTeXt EmDash = return $ text "---" +inlineToConTeXt EnDash = return $ text "--" +inlineToConTeXt Ellipses = return $ text "\\ldots{}" +inlineToConTeXt (Str str) = return $ text $ stringToConTeXt str +inlineToConTeXt (Math InlineMath str) = return $ char '$' <> text str <> char '$' +inlineToConTeXt (Math DisplayMath str) = return $ text "\\startformula " <> text str <> text " \\stopformula" +inlineToConTeXt (TeX str) = return $ text str +inlineToConTeXt (HtmlInline _) = return empty +inlineToConTeXt (LineBreak) = return $ text "\\crlf\n" +inlineToConTeXt Space = return $ char ' ' +inlineToConTeXt (Link [Code str] (src, tit)) = -- since ConTeXt has its own + inlineToConTeXt (Link [Str str] (src, tit)) -- way of printing links... +inlineToConTeXt (Link txt (src, _)) = do + st <- get + let next = stNextRef st + put $ st {stNextRef = next + 1} + let ref = show next + label <- inlineListToConTeXt txt + return $ text "\\useURL[" <> text ref <> text "][" <> text src <> + text "][][" <> label <> text "]\\from[" <> text ref <> char ']' +inlineToConTeXt (Image alternate (src, tit)) = do + alt <- inlineListToConTeXt alternate + return $ text "\\placefigure\n[]\n[fig:" <> alt <> text "]\n{" <> + text tit <> text "}\n{\\externalfigure[" <> text src <> text "]}" +inlineToConTeXt (Note contents) = do + contents' <- blockListToConTeXt contents + let rawnote = stripTrailingNewlines $ render contents' + -- note: a \n before } is needed when note ends with a \stoptyping + let optNewline = "\\stoptyping" `isSuffixOf` rawnote + return $ text "\\footnote{" <> + text rawnote <> (if optNewline then char '\n' else empty) <> char '}' + diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs new file mode 100644 index 000000000..3e535a87e --- /dev/null +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -0,0 +1,262 @@ +{- +Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.Docbook + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to Docbook XML. +-} +module Text.Pandoc.Writers.Docbook ( writeDocbook) where +import Text.Pandoc.Definition +import Text.Pandoc.XML +import Text.Pandoc.Shared +import Text.Pandoc.Readers.TeXMath +import Data.List ( isPrefixOf, drop, intercalate ) +import Text.PrettyPrint.HughesPJ hiding ( Str ) + +-- | Convert list of authors to a docbook <author> section +authorToDocbook :: [Char] -> Doc +authorToDocbook name = inTagsIndented "author" $ + if ',' `elem` name + then -- last name first + let (lastname, rest) = break (==',') name + firstname = removeLeadingSpace rest in + inTagsSimple "firstname" (text $ escapeStringForXML firstname) <> + inTagsSimple "surname" (text $ escapeStringForXML lastname) + else -- last name last + let namewords = words name + lengthname = length namewords + (firstname, lastname) = case lengthname of + 0 -> ("","") + 1 -> ("", name) + n -> (intercalate " " (take (n-1) namewords), last namewords) + 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 title authors date) blocks) = + let head' = if writerStandalone opts + then text (writerHeader opts) + else empty + meta = if writerStandalone opts + then inTagsIndented "articleinfo" $ + (inTagsSimple "title" (wrap opts title)) $$ + (vcat (map authorToDocbook authors)) $$ + (inTagsSimple "date" (text $ escapeStringForXML date)) + else empty + elements = hierarchicalize blocks + before = writerIncludeBefore opts + after = writerIncludeAfter opts + body = (if null before then empty else text before) $$ + vcat (map (elementToDocbook opts) elements) $$ + (if null after then empty else text after) + body' = if writerStandalone opts + then inTagsIndented "article" (meta $$ body) + else body + in render $ head' $$ body' $$ text "" + +-- | Convert an Element to Docbook. +elementToDocbook :: WriterOptions -> Element -> Doc +elementToDocbook opts (Blk block) = blockToDocbook opts block +elementToDocbook opts (Sec title elements) = + -- Docbook doesn't allow sections with no content, so insert some if needed + let elements' = if null elements + then [Blk (Para [])] + else elements + in inTagsIndented "section" $ + inTagsSimple "title" (wrap opts title) $$ + vcat (map (elementToDocbook opts) elements') + +-- | Convert a list of Pandoc blocks to Docbook. +blocksToDocbook :: WriterOptions -> [Block] -> Doc +blocksToDocbook opts = vcat . map (blockToDocbook opts) + +-- | Auxiliary function to convert Plain block to Para. +plainToPara :: Block -> Block +plainToPara (Plain x) = Para x +plainToPara x = x + +-- | Convert a list of pairs of terms and definitions into a list of +-- Docbook varlistentrys. +deflistItemsToDocbook :: WriterOptions -> [([Inline],[Block])] -> Doc +deflistItemsToDocbook opts items = + vcat $ map (\(term, def) -> deflistItemToDocbook opts term def) items + +-- | Convert a term and a list of blocks into a Docbook varlistentry. +deflistItemToDocbook :: WriterOptions -> [Inline] -> [Block] -> Doc +deflistItemToDocbook opts term def = + let def' = map plainToPara def + in inTagsIndented "varlistentry" $ + inTagsIndented "term" (inlinesToDocbook opts term) $$ + inTagsIndented "listitem" (blocksToDocbook opts def') + +-- | Convert a list of lists of blocks to a list of Docbook list items. +listItemsToDocbook :: WriterOptions -> [[Block]] -> Doc +listItemsToDocbook opts items = vcat $ map (listItemToDocbook opts) items + +-- | Convert a list of blocks into a Docbook list item. +listItemToDocbook :: WriterOptions -> [Block] -> Doc +listItemToDocbook opts item = + inTagsIndented "listitem" $ blocksToDocbook opts $ map plainToPara item + +-- | Convert a Pandoc block element to Docbook. +blockToDocbook :: WriterOptions -> Block -> Doc +blockToDocbook _ Null = empty +blockToDocbook _ (Header _ _) = empty -- should not occur after hierarchicalize +blockToDocbook opts (Plain lst) = wrap opts lst +blockToDocbook opts (Para lst) = inTagsIndented "para" $ wrap opts lst +blockToDocbook opts (BlockQuote blocks) = + inTagsIndented "blockquote" $ blocksToDocbook opts blocks +blockToDocbook _ (CodeBlock _ str) = + text "<screen>\n" <> text (escapeStringForXML str) <> text "\n</screen>" +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 -> [] + Decimal -> [("numeration", "arabic")] + UpperAlpha -> [("numeration", "upperalpha")] + LowerAlpha -> [("numeration", "loweralpha")] + UpperRoman -> [("numeration", "upperroman")] + LowerRoman -> [("numeration", "lowerroman")] + items = if start == 1 + then listItemsToDocbook opts (first:rest) + else (inTags True "listitem" [("override",show start)] + (blocksToDocbook opts $ map plainToPara first)) $$ + listItemsToDocbook opts rest + in inTags True "orderedlist" attribs items +blockToDocbook opts (DefinitionList lst) = + inTagsIndented "variablelist" $ deflistItemsToDocbook opts lst +blockToDocbook _ (RawHtml str) = text str -- raw XML block +blockToDocbook _ HorizontalRule = empty -- not semantic +blockToDocbook opts (Table caption aligns widths headers rows) = + let alignStrings = map alignmentToString aligns + captionDoc = if null caption + then empty + else inTagsIndented "caption" + (inlinesToDocbook opts caption) + tableType = if isEmpty captionDoc then "informaltable" else "table" + in inTagsIndented tableType $ captionDoc $$ + (colHeadsToDocbook opts alignStrings widths headers) $$ + (vcat $ map (tableRowToDocbook opts alignStrings) rows) + +colHeadsToDocbook :: WriterOptions + -> [[Char]] + -> [Double] + -> [[Block]] + -> Doc +colHeadsToDocbook opts alignStrings widths headers = + let heads = zipWith3 (\align width item -> + tableItemToDocbook opts "th" align width item) + alignStrings widths headers + in inTagsIndented "tr" $ vcat heads + +alignmentToString :: Alignment -> [Char] +alignmentToString alignment = case alignment of + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" + AlignDefault -> "left" + +tableRowToDocbook :: WriterOptions -> [[Char]] -> [[Block]] -> Doc +tableRowToDocbook opts aligns cols = inTagsIndented "tr" $ + vcat $ zipWith3 (tableItemToDocbook opts "td") aligns (repeat 0) cols + +tableItemToDocbook :: WriterOptions + -> [Char] + -> [Char] + -> Double + -> [Block] + -> Doc +tableItemToDocbook opts tag align width item = + let attrib = [("align", align)] ++ + if width /= 0 + then [("style", "{width: " ++ + show (truncate (100*width) :: Integer) ++ "%;}")] + else [] + in inTags True tag attrib $ vcat $ map (blockToDocbook opts) item + +-- | Take list of inline elements and return wrapped doc. +wrap :: WriterOptions -> [Inline] -> Doc +wrap opts lst = if writerWrapText opts + then fsep $ map (inlinesToDocbook opts) (splitBy Space lst) + else inlinesToDocbook opts lst + +-- | Convert a list of inline elements to Docbook. +inlinesToDocbook :: WriterOptions -> [Inline] -> Doc +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) = + inTagsSimple "emphasis" $ inlinesToDocbook opts lst +inlineToDocbook opts (Strong lst) = + inTags False "emphasis" [("role", "strong")] $ inlinesToDocbook opts lst +inlineToDocbook opts (Strikeout lst) = + inTags False "emphasis" [("role", "strikethrough")] $ + inlinesToDocbook opts lst +inlineToDocbook opts (Superscript lst) = + inTagsSimple "superscript" $ inlinesToDocbook opts lst +inlineToDocbook opts (Subscript lst) = + inTagsSimple "subscript" $ inlinesToDocbook opts lst +inlineToDocbook opts (SmallCaps lst) = + inTags False "emphasis" [("role", "smallcaps")] $ + inlinesToDocbook opts lst +inlineToDocbook opts (Quoted _ lst) = + inTagsSimple "quote" $ inlinesToDocbook opts lst +inlineToDocbook opts (Cite _ lst) = + inlinesToDocbook opts lst +inlineToDocbook _ Apostrophe = char '\'' +inlineToDocbook _ Ellipses = text "…" +inlineToDocbook _ EmDash = text "—" +inlineToDocbook _ EnDash = text "–" +inlineToDocbook _ (Code str) = + inTagsSimple "literal" $ text (escapeStringForXML str) +inlineToDocbook opts (Math _ str) = inlinesToDocbook opts $ readTeXMath str +inlineToDocbook _ (TeX _) = empty +inlineToDocbook _ (HtmlInline _) = empty +inlineToDocbook _ LineBreak = text $ "<literallayout></literallayout>" +inlineToDocbook _ Space = char ' ' +inlineToDocbook opts (Link txt (src, _)) = + if isPrefixOf "mailto:" src + then let src' = drop 7 src + emailLink = inTagsSimple "email" $ text $ + escapeStringForXML $ src' + in if txt == [Code src'] + then emailLink + else inlinesToDocbook opts txt <+> char '(' <> emailLink <> + char ')' + else inTags False "ulink" [("url", src)] $ inlinesToDocbook opts txt +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) = + inTagsIndented "footnote" $ blocksToDocbook opts contents diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs new file mode 100644 index 000000000..fb7320e92 --- /dev/null +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -0,0 +1,557 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{- +Copyright (C) 2006-8 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.HTML + Copyright : Copyright (C) 2006-8 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to HTML. +-} +module Text.Pandoc.Writers.HTML ( writeHtml , writeHtmlString ) where +import Text.Pandoc.Definition +import Text.Pandoc.LaTeXMathML +import Text.Pandoc.CharacterReferences ( decodeCharacterReferences ) +import Text.Pandoc.Shared +import Text.Pandoc.Readers.TeXMath +import Text.Pandoc.Highlighting ( highlightHtml, defaultHighlightingCss ) +import Numeric ( showHex ) +import Data.Char ( ord, toLower, isAlpha ) +import Data.List ( isPrefixOf, intercalate ) +import qualified Data.Set as S +import Control.Monad.State +import Text.XHtml.Transitional hiding ( stringToHtml ) + +data WriterState = WriterState + { stNotes :: [Html] -- ^ List of notes + , stIds :: [String] -- ^ List of header identifiers + , stMath :: Bool -- ^ Math is used in document + , stCSS :: S.Set String -- ^ CSS to include in header + } deriving Show + +defaultWriterState :: WriterState +defaultWriterState = WriterState {stNotes= [], stIds = [], + stMath = False, stCSS = S.empty} + +-- Helpers to render HTML with the appropriate function. + +render :: (HTML html) => WriterOptions -> html -> String +render opts = if writerWrapText opts then renderHtml else showHtml + +renderFragment :: (HTML html) => WriterOptions -> html -> String +renderFragment opts = if writerWrapText opts + then renderHtmlFragment + else showHtmlFragment + +-- | Slightly modified version of Text.XHtml's stringToHtml. +-- Only uses numerical entities for 0xff and greater. +-- Adds . +stringToHtml :: String -> Html +stringToHtml = primHtml . concatMap fixChar + where + fixChar '<' = "<" + fixChar '>' = ">" + fixChar '&' = "&" + fixChar '"' = """ + fixChar '\160' = " " + fixChar c | ord c < 0xff = [c] + fixChar c = "&#" ++ show (ord c) ++ ";" + +-- | Convert Pandoc document to Html string. +writeHtmlString :: WriterOptions -> Pandoc -> String +writeHtmlString opts = + if writerStandalone opts + then render opts . writeHtml opts + else renderFragment opts . writeHtml opts + +-- | Convert Pandoc document to Html structure. +writeHtml :: WriterOptions -> Pandoc -> Html +writeHtml opts (Pandoc (Meta tit authors date) blocks) = + let titlePrefix = writerTitlePrefix opts + topTitle = evalState (inlineListToHtml opts tit) defaultWriterState + topTitle' = if null titlePrefix + then topTitle + else if null tit + then stringToHtml titlePrefix + else titlePrefix +++ " - " +++ topTitle + metadata = thetitle topTitle' +++ + meta ! [httpequiv "Content-Type", + content "text/html; charset=UTF-8"] +++ + meta ! [name "generator", content "pandoc"] +++ + (toHtmlFromList $ + map (\a -> meta ! [name "author", content a]) authors) +++ + (if null date + then noHtml + else meta ! [name "date", content date]) + titleHeader = if writerStandalone opts && not (null tit) && + not (writerS5 opts) + then h1 ! [theclass "title"] $ topTitle + else noHtml + headerBlocks = filter isHeaderBlock blocks + ids = uniqueIdentifiers $ + map (\(Header _ lst) -> lst) headerBlocks + toc = if writerTableOfContents opts + then tableOfContents opts headerBlocks ids + else noHtml + (blocks', newstate) = + runState (blockListToHtml opts blocks) + (defaultWriterState {stIds = ids}) + cssLines = stCSS newstate + css = if S.null cssLines + then noHtml + else style ! [thetype "text/css"] $ primHtml $ + '\n':(unlines $ S.toList cssLines) + math = if stMath newstate + then case writerHTMLMathMethod opts of + LaTeXMathML Nothing -> + primHtml latexMathMLScript + LaTeXMathML (Just url) -> + script ! + [src url, thetype "text/javascript"] $ + noHtml + JsMath (Just url) -> + script ! + [src url, thetype "text/javascript"] $ + noHtml + _ -> noHtml + else noHtml + head' = header $ metadata +++ math +++ css +++ + primHtml (writerHeader opts) + notes = reverse (stNotes newstate) + before = primHtml $ writerIncludeBefore opts + after = primHtml $ writerIncludeAfter opts + thebody = before +++ titleHeader +++ toc +++ blocks' +++ + footnoteSection notes +++ after + in if writerStandalone opts + then head' +++ body thebody + else thebody + +-- | Construct table of contents from list of header blocks and identifiers. +-- Assumes there are as many identifiers as header blocks. +tableOfContents :: WriterOptions -> [Block] -> [String] -> Html +tableOfContents _ [] _ = noHtml +tableOfContents opts headers ids = + let opts' = opts { writerIgnoreNotes = True } + contentsTree = hierarchicalize headers + contents = evalState (mapM (elementToListItem opts') contentsTree) + (defaultWriterState {stIds = ids}) + in thediv ! [identifier "toc"] $ unordList contents + +-- | Converts an Element to a list item for a table of contents, +-- retrieving the appropriate identifier from state. +elementToListItem :: WriterOptions -> Element -> State WriterState Html +elementToListItem _ (Blk _) = return noHtml +elementToListItem opts (Sec headerText subsecs) = do + st <- get + let ids = stIds st + let (id', rest) = if null ids + then ("", []) + else (head ids, tail ids) + put $ st {stIds = rest} + txt <- inlineListToHtml opts headerText + subHeads <- mapM (elementToListItem opts) subsecs + let subList = if null subHeads + then noHtml + else unordList subHeads + return $ (anchor ! [href ("#" ++ id'), identifier ("TOC-" ++ id')] $ txt) +++ + subList + +-- | Convert list of Note blocks to a footnote <div>. +-- Assumes notes are sorted. +footnoteSection :: [Html] -> Html +footnoteSection notes = + if null notes + then noHtml + else thediv ! [theclass "footnotes"] $ hr +++ (olist << notes) + + +-- | Parse a mailto link; return Just (name, domain) or Nothing. +parseMailto :: String -> Maybe (String, String) +parseMailto ('m':'a':'i':'l':'t':'o':':':addr) = + let (name', rest) = span (/='@') addr + domain = drop 1 rest + in Just (name', domain) +parseMailto _ = Nothing + +-- | Obfuscate a "mailto:" link. +obfuscateLink :: WriterOptions -> String -> String -> Html +obfuscateLink opts txt s | writerEmailObfuscation opts == NoObfuscation = + anchor ! [href s] << txt +obfuscateLink opts txt s = + let meth = writerEmailObfuscation opts + s' = map toLower s + in case parseMailto s' of + (Just (name', domain)) -> + let domain' = substitute "." " dot " domain + at' = obfuscateChar '@' + (linkText, altText) = + if txt == drop 7 s' -- autolink + then ("'<code>'+e+'</code>'", name' ++ " at " ++ domain') + else ("'" ++ txt ++ "'", txt ++ " (" ++ name' ++ " at " ++ + domain' ++ ")") + in case meth of + ReferenceObfuscation -> + -- need to use primHtml or &'s are escaped to & in URL + primHtml $ "<a href=\"" ++ (obfuscateString s') + ++ "\">" ++ (obfuscateString txt) ++ "</a>" + JavascriptObfuscation -> + (script ! [thetype "text/javascript"] $ + primHtml ("\n<!--\nh='" ++ + obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++ + obfuscateString name' ++ "';e=n+a+h;\n" ++ + "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\">'+" ++ + linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) +++ + noscript (primHtml $ obfuscateString altText) + _ -> error $ "Unknown obfuscation method: " ++ show meth + _ -> anchor ! [href s] $ primHtml txt -- malformed email + +-- | Obfuscate character as entity. +obfuscateChar :: Char -> String +obfuscateChar char = + let num = ord char + numstr = if even num then show num else "x" ++ showHex num "" + in "&#" ++ numstr ++ ";" + +-- | Obfuscate string using entities. +obfuscateString :: String -> String +obfuscateString = concatMap obfuscateChar . decodeCharacterReferences + +-- | True if character is a punctuation character (unicode). +isPunctuation :: Char -> Bool +isPunctuation c = + let c' = ord c + in if c `elem` "!\"'()*,-./:;<>?[\\]`{|}~" || c' >= 0x2000 && c' <= 0x206F || + c' >= 0xE000 && c' <= 0xE0FF + then True + else False + +-- | Add CSS for document header. +addToCSS :: String -> State WriterState () +addToCSS item = do + st <- get + let current = stCSS st + put $ st {stCSS = S.insert item current} + +-- | Convert Pandoc inline list to plain text identifier. +inlineListToIdentifier :: [Inline] -> String +inlineListToIdentifier = dropWhile (not . isAlpha) . inlineListToIdentifier' + +inlineListToIdentifier' :: [Inline] -> [Char] +inlineListToIdentifier' [] = "" +inlineListToIdentifier' (x:xs) = + xAsText ++ inlineListToIdentifier' xs + where xAsText = case x of + Str s -> filter (\c -> c == '-' || not (isPunctuation c)) $ + intercalate "-" $ words $ map toLower s + Emph lst -> inlineListToIdentifier' lst + Strikeout lst -> inlineListToIdentifier' lst + Superscript lst -> inlineListToIdentifier' lst + SmallCaps lst -> inlineListToIdentifier' lst + Subscript lst -> inlineListToIdentifier' lst + Strong lst -> inlineListToIdentifier' lst + Quoted _ lst -> inlineListToIdentifier' lst + Cite _ lst -> inlineListToIdentifier' lst + Code s -> s + Space -> "-" + EmDash -> "-" + EnDash -> "-" + Apostrophe -> "" + Ellipses -> "" + LineBreak -> "-" + Math _ _ -> "" + TeX _ -> "" + HtmlInline _ -> "" + Link lst _ -> inlineListToIdentifier' lst + Image lst _ -> inlineListToIdentifier' lst + Note _ -> "" + +-- | Return unique identifiers for list of inline lists. +uniqueIdentifiers :: [[Inline]] -> [String] +uniqueIdentifiers ls = + let addIdentifier (nonuniqueIds, uniqueIds) l = + let new = inlineListToIdentifier l + matches = length $ filter (== new) nonuniqueIds + new' = (if null new then "section" else new) ++ + if matches > 0 then ("-" ++ show matches) else "" + in (new:nonuniqueIds, new':uniqueIds) + in reverse $ snd $ foldl addIdentifier ([],[]) ls + +-- | Convert Pandoc block element to HTML. +blockToHtml :: WriterOptions -> Block -> State WriterState Html +blockToHtml _ Null = return $ noHtml +blockToHtml opts (Plain lst) = inlineListToHtml opts lst +blockToHtml opts (Para lst) = inlineListToHtml opts lst >>= (return . paragraph) +blockToHtml _ (RawHtml str) = return $ primHtml str +blockToHtml _ (HorizontalRule) = return $ hr +blockToHtml opts (CodeBlock (_,classes,_) rawCode) | "haskell" `elem` classes && + writerLiterateHaskell opts = + let classes' = map (\c -> if c == "haskell" then "literatehaskell" else c) classes + in blockToHtml opts $ CodeBlock ("",classes',[]) $ intercalate "\n" $ map ("> " ++) $ lines rawCode +blockToHtml _ (CodeBlock attr@(_,classes,_) rawCode) = do + case highlightHtml attr rawCode of + Left _ -> -- change leading newlines into <br /> tags, because some + -- browsers ignore leading newlines in pre blocks + let (leadingBreaks, rawCode') = span (=='\n') rawCode + in return $ pre ! (if null classes + then [] + else [theclass $ unwords classes]) $ thecode << + (replicate (length leadingBreaks) br +++ + [stringToHtml $ rawCode' ++ "\n"]) + Right h -> addToCSS defaultHighlightingCss >> return h +blockToHtml opts (BlockQuote blocks) = + -- in S5, treat list in blockquote specially + -- if default is incremental, make it nonincremental; + -- otherwise incremental + if writerS5 opts + then let inc = not (writerIncremental opts) in + case blocks of + [BulletList lst] -> blockToHtml (opts {writerIncremental = inc}) + (BulletList lst) + [OrderedList attribs lst] -> + blockToHtml (opts {writerIncremental = inc}) + (OrderedList attribs lst) + _ -> blockListToHtml opts blocks >>= + (return . blockquote) + else blockListToHtml opts blocks >>= (return . blockquote) +blockToHtml opts (Header level lst) = do + contents <- inlineListToHtml opts lst + st <- get + let ids = stIds st + let (id', rest) = if null ids + then ("", []) + else (head ids, tail ids) + put $ st {stIds = rest} + let attribs = if writerStrictMarkdown opts && not (writerTableOfContents opts) + then [] + else [identifier id'] + let contents' = if writerTableOfContents opts + then anchor ! [href ("#TOC-" ++ id')] $ contents + else contents + return $ case level of + 1 -> h1 contents' ! attribs + 2 -> h2 contents' ! attribs + 3 -> h3 contents' ! attribs + 4 -> h4 contents' ! attribs + 5 -> h5 contents' ! attribs + 6 -> h6 contents' ! attribs + _ -> paragraph contents' ! attribs +blockToHtml opts (BulletList lst) = do + contents <- mapM (blockListToHtml opts) lst + let attribs = if writerIncremental opts + then [theclass "incremental"] + else [] + return $ unordList ! attribs $ contents +blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do + contents <- mapM (blockListToHtml opts) lst + let numstyle' = camelCaseToHyphenated $ show numstyle + let attribs = (if writerIncremental opts + then [theclass "incremental"] + else []) ++ + (if startnum /= 1 + then [start startnum] + else []) ++ + (if numstyle /= DefaultStyle + then [thestyle $ "list-style-type: " ++ numstyle' ++ ";"] + else []) + return $ ordList ! attribs $ contents +blockToHtml opts (DefinitionList lst) = do + contents <- mapM (\(term, def) -> do term' <- inlineListToHtml opts term + def' <- blockListToHtml opts def + return $ (term', def')) lst + let attribs = if writerIncremental opts + then [theclass "incremental"] + else [] + return $ defList ! attribs $ contents +blockToHtml opts (Table capt aligns widths headers rows') = do + let alignStrings = map alignmentToString aligns + captionDoc <- if null capt + then return noHtml + else inlineListToHtml opts capt >>= return . caption + colHeads <- colHeadsToHtml opts alignStrings + widths headers + rows'' <- zipWithM (tableRowToHtml opts alignStrings) (cycle ["odd", "even"]) rows' + return $ table $ captionDoc +++ colHeads +++ rows'' + +colHeadsToHtml :: WriterOptions + -> [[Char]] + -> [Double] + -> [[Block]] + -> State WriterState Html +colHeadsToHtml opts alignStrings widths headers = do + heads <- sequence $ zipWith3 + (\alignment columnwidth item -> tableItemToHtml opts th alignment columnwidth item) + alignStrings widths headers + return $ tr ! [theclass "header"] $ toHtmlFromList heads + +alignmentToString :: Alignment -> [Char] +alignmentToString alignment = case alignment of + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" + AlignDefault -> "left" + +tableRowToHtml :: WriterOptions + -> [[Char]] + -> String + -> [[Block]] + -> State WriterState Html +tableRowToHtml opts aligns rowclass columns = + (sequence $ zipWith3 (tableItemToHtml opts td) aligns (repeat 0) columns) >>= + return . (tr ! [theclass rowclass]) . toHtmlFromList + +tableItemToHtml :: WriterOptions + -> (Html -> Html) + -> [Char] + -> Double + -> [Block] + -> State WriterState Html +tableItemToHtml opts tag' align' width' item = do + contents <- blockListToHtml opts item + let attrib = [align align'] ++ + if width' /= 0 + then [thestyle ("width: " ++ (show (truncate (100 * width') :: Integer)) ++ "%;")] + else [] + return $ tag' ! attrib $ contents + +blockListToHtml :: WriterOptions -> [Block] -> State WriterState Html +blockListToHtml opts lst = + mapM (blockToHtml opts) lst >>= return . toHtmlFromList + +-- | Convert list of Pandoc inline elements to HTML. +inlineListToHtml :: WriterOptions -> [Inline] -> State WriterState Html +inlineListToHtml opts lst = + mapM (inlineToHtml opts) lst >>= return . toHtmlFromList + +-- | Convert Pandoc inline element to HTML. +inlineToHtml :: WriterOptions -> Inline -> State WriterState Html +inlineToHtml opts inline = + case inline of + (Str str) -> return $ stringToHtml str + (Space) -> return $ stringToHtml " " + (LineBreak) -> return $ br + (EmDash) -> return $ primHtmlChar "mdash" + (EnDash) -> return $ primHtmlChar "ndash" + (Ellipses) -> return $ primHtmlChar "hellip" + (Apostrophe) -> return $ primHtmlChar "rsquo" + (Emph lst) -> inlineListToHtml opts lst >>= return . emphasize + (Strong lst) -> inlineListToHtml opts lst >>= return . strong + (Code str) -> return $ thecode << str + (Strikeout lst) -> inlineListToHtml opts lst >>= + return . (thespan ! [thestyle "text-decoration: line-through;"]) + (SmallCaps lst) -> inlineListToHtml opts lst >>= + return . (thespan ! [thestyle "font-variant: small-caps;"]) + (Superscript lst) -> inlineListToHtml opts lst >>= return . sup + (Subscript lst) -> inlineListToHtml opts lst >>= return . sub + (Quoted quoteType lst) -> + let (leftQuote, rightQuote) = case quoteType of + SingleQuote -> (primHtmlChar "lsquo", + primHtmlChar "rsquo") + DoubleQuote -> (primHtmlChar "ldquo", + primHtmlChar "rdquo") + in do contents <- inlineListToHtml opts lst + return $ leftQuote +++ contents +++ rightQuote + (Math t str) -> + modify (\st -> st {stMath = True}) >> + (case writerHTMLMathMethod opts of + LaTeXMathML _ -> + -- putting LaTeXMathML in container with class "LaTeX" prevents + -- non-math elements on the page from being treated as math by + -- the javascript + return $ thespan ! [theclass "LaTeX"] $ + if t == InlineMath + then primHtml ("$" ++ str ++ "$") + else primHtml ("$$" ++ str ++ "$$") + JsMath _ -> + return $ if t == InlineMath + then thespan ! [theclass "math"] $ primHtml str + else thediv ! [theclass "math"] $ primHtml str + MimeTeX url -> + return $ image ! [src (url ++ "?" ++ str), + alt str, title str] + GladTeX -> + return $ primHtml $ "<EQ>" ++ str ++ "</EQ>" + PlainMath -> + inlineListToHtml opts (readTeXMath str) >>= + return . (thespan ! [theclass "math"])) + (TeX str) -> case writerHTMLMathMethod opts of + LaTeXMathML _ -> do modify (\st -> st {stMath = True}) + return $ primHtml str + _ -> return noHtml + (HtmlInline str) -> return $ primHtml str + (Link [Code str] (s,_)) | "mailto:" `isPrefixOf` s -> + return $ obfuscateLink opts str s + (Link txt (s,_)) | "mailto:" `isPrefixOf` s -> do + linkText <- inlineListToHtml opts txt + return $ obfuscateLink opts (show linkText) s + (Link txt (s,tit)) -> do + linkText <- inlineListToHtml opts txt + return $ anchor ! ([href s] ++ + if null tit then [] else [title tit]) $ + linkText + (Image txt (s,tit)) -> do + alternate <- inlineListToHtml opts txt + let alternate' = renderFragment opts alternate + let attributes = [src s] ++ + (if null tit + then [] + else [title tit]) ++ + if null txt + then [] + else [alt alternate'] + return $ image ! attributes + -- note: null title included, as in Markdown.pl + (Note contents) -> do + st <- get + let notes = stNotes st + let number = (length notes) + 1 + let ref = show number + htmlContents <- blockListToNote opts ref contents + -- push contents onto front of notes + put $ st {stNotes = (htmlContents:notes)} + return $ anchor ! [href ("#fn" ++ ref), + theclass "footnoteRef", + identifier ("fnref" ++ ref)] << + sup << ref + (Cite _ il) -> inlineListToHtml opts il + +blockListToNote :: WriterOptions -> String -> [Block] -> State WriterState Html +blockListToNote opts ref blocks = + -- If last block is Para or Plain, include the backlink at the end of + -- that block. Otherwise, insert a new Plain block with the backlink. + let backlink = [HtmlInline $ " <a href=\"#fnref" ++ ref ++ + "\" class=\"footnoteBackLink\"" ++ + " title=\"Jump back to footnote " ++ ref ++ "\">↩</a>"] + blocks' = if null blocks + then [] + else let lastBlock = last blocks + otherBlocks = init blocks + in case lastBlock of + (Para lst) -> otherBlocks ++ + [Para (lst ++ backlink)] + (Plain lst) -> otherBlocks ++ + [Plain (lst ++ backlink)] + _ -> otherBlocks ++ [lastBlock, + Plain backlink] + in do contents <- blockListToHtml opts blocks' + return $ li ! [identifier ("fn" ++ ref)] $ contents + diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs new file mode 100644 index 000000000..f3cbf1acb --- /dev/null +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -0,0 +1,331 @@ +{- +Copyright (C) 2006-8 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.LaTeX + Copyright : Copyright (C) 2006-8 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' format into LaTeX. +-} +module Text.Pandoc.Writers.LaTeX ( writeLaTeX ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Printf ( printf ) +import Data.List ( (\\), isSuffixOf, intercalate ) +import Data.Char ( toLower ) +import qualified Data.Set as S +import Control.Monad.State +import Text.PrettyPrint.HughesPJ hiding ( Str ) + +data WriterState = + WriterState { stIncludes :: S.Set String -- strings to include in header + , stInNote :: Bool -- @True@ if we're in a note + , stOLLevel :: Int -- level of ordered list nesting + , stOptions :: WriterOptions -- writer options, so they don't have to be parameter + } + +-- | Add line to header. +addToHeader :: String -> State WriterState () +addToHeader str = do + st <- get + let includes = stIncludes st + put st {stIncludes = S.insert str includes} + +-- | Convert Pandoc to LaTeX. +writeLaTeX :: WriterOptions -> Pandoc -> String +writeLaTeX options document = + render $ evalState (pandocToLaTeX options document) $ + WriterState { stIncludes = S.empty, stInNote = False, stOLLevel = 1, stOptions = options } + +pandocToLaTeX :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToLaTeX options (Pandoc meta blocks) = do + main <- blockListToLaTeX blocks + head' <- if writerStandalone options + then latexHeader options meta + else return empty + let before = if null (writerIncludeBefore options) + then empty + else text (writerIncludeBefore options) + let after = if null (writerIncludeAfter options) + then empty + else text (writerIncludeAfter options) + let body = before $$ main $$ after + let toc = if writerTableOfContents options + then text "\\tableofcontents\n" + else empty + let foot = if writerStandalone options + then text "\\end{document}" + else empty + return $ head' $$ toc $$ body $$ foot + +-- | Insert bibliographic information into LaTeX header. +latexHeader :: WriterOptions -- ^ Options, including LaTeX header + -> Meta -- ^ Meta with bibliographic information + -> State WriterState Doc +latexHeader options (Meta title authors date) = do + titletext <- if null title + then return empty + else inlineListToLaTeX title >>= return . inCmd "title" + headerIncludes <- get >>= return . S.toList . stIncludes + let extras = text $ unlines headerIncludes + let verbatim = if "\\usepackage{fancyvrb}" `elem` headerIncludes + then text "\\VerbatimFootnotes % allows verbatim text in footnotes" + else empty + let authorstext = text $ "\\author{" ++ + intercalate "\\\\" (map stringToLaTeX authors) ++ "}" + let datetext = if date == "" + then empty + else text $ "\\date{" ++ stringToLaTeX date ++ "}" + let maketitle = if null title then empty else text "\\maketitle" + let secnumline = if (writerNumberSections options) + then empty + else text "\\setcounter{secnumdepth}{0}" + let baseHeader = text $ writerHeader options + let header = baseHeader $$ extras + return $ header $$ secnumline $$ verbatim $$ titletext $$ authorstext $$ + datetext $$ text "\\begin{document}" $$ maketitle $$ text "" + +-- escape things as needed for LaTeX + +stringToLaTeX :: String -> String +stringToLaTeX = escapeStringUsing latexEscapes + where latexEscapes = backslashEscapes "{}$%&_#" ++ + [ ('^', "\\^{}") + , ('\\', "\\textbackslash{}") + , ('~', "\\ensuremath{\\sim}") + , ('|', "\\textbar{}") + , ('<', "\\textless{}") + , ('>', "\\textgreater{}") + , ('\160', "~") + ] + +-- | Puts contents into LaTeX command. +inCmd :: String -> Doc -> Doc +inCmd cmd contents = char '\\' <> text cmd <> braces contents + +-- | Remove all code elements from list of inline elements +-- (because it's illegal to have verbatim inside some command arguments) +deVerb :: [Inline] -> [Inline] +deVerb [] = [] +deVerb ((Code str):rest) = + (TeX $ "\\texttt{" ++ stringToLaTeX str ++ "}"):(deVerb rest) +deVerb (other:rest) = other:(deVerb rest) + +-- | Convert Pandoc block element to LaTeX. +blockToLaTeX :: Block -- ^ Block to convert + -> State WriterState Doc +blockToLaTeX Null = return empty +blockToLaTeX (Plain lst) = do + st <- get + let opts = stOptions st + wrapTeXIfNeeded opts True inlineListToLaTeX lst +blockToLaTeX (Para lst) = do + st <- get + let opts = stOptions st + result <- wrapTeXIfNeeded opts True inlineListToLaTeX lst + return $ result <> char '\n' +blockToLaTeX (BlockQuote lst) = do + contents <- blockListToLaTeX lst + return $ text "\\begin{quote}" $$ contents $$ text "\\end{quote}" +blockToLaTeX (CodeBlock (_,classes,_) str) = do + st <- get + env <- if writerLiterateHaskell (stOptions st) && "haskell" `elem` classes + then return "code" + else if stInNote st + then do addToHeader "\\usepackage{fancyvrb}" + return "Verbatim" + else return "verbatim" + return $ text ("\\begin{" ++ env ++ "}\n") <> text str <> + text ("\n\\end{" ++ env ++ "}") +blockToLaTeX (RawHtml _) = return empty +blockToLaTeX (BulletList lst) = do + items <- mapM listItemToLaTeX lst + return $ text "\\begin{itemize}" $$ vcat items $$ text "\\end{itemize}" +blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do + st <- get + let oldlevel = stOLLevel st + put $ st {stOLLevel = oldlevel + 1} + items <- mapM listItemToLaTeX lst + modify (\s -> s {stOLLevel = oldlevel}) + exemplar <- if numstyle /= DefaultStyle || numdelim /= DefaultDelim + then do addToHeader "\\usepackage{enumerate}" + return $ char '[' <> + text (head (orderedListMarkers (1, numstyle, + numdelim))) <> char ']' + else return empty + let resetcounter = if start /= 1 && oldlevel <= 4 + then text $ "\\setcounter{enum" ++ + map toLower (toRomanNumeral oldlevel) ++ + "}{" ++ show (start - 1) ++ "}" + else empty + return $ text "\\begin{enumerate}" <> exemplar $$ resetcounter $$ + vcat items $$ text "\\end{enumerate}" +blockToLaTeX (DefinitionList lst) = do + items <- mapM defListItemToLaTeX lst + return $ text "\\begin{description}" $$ vcat items $$ + text "\\end{description}" +blockToLaTeX HorizontalRule = return $ text $ + "\\begin{center}\\rule{3in}{0.4pt}\\end{center}\n" +blockToLaTeX (Header level lst) = do + txt <- inlineListToLaTeX (deVerb lst) + return $ if (level > 0) && (level <= 3) + then text ("\\" ++ (concat (replicate (level - 1) "sub")) ++ + "section{") <> txt <> text "}\n" + else txt <> char '\n' +blockToLaTeX (Table caption aligns widths heads rows) = do + headers <- tableRowToLaTeX heads + captionText <- inlineListToLaTeX caption + rows' <- mapM tableRowToLaTeX rows + let colWidths = map (printf "%.2f") widths + let colDescriptors = concat $ zipWith + (\width align -> ">{\\PBS" ++ + (case align of + AlignLeft -> "\\raggedright" + AlignRight -> "\\raggedleft" + AlignCenter -> "\\centering" + AlignDefault -> "\\raggedright") ++ + "\\hspace{0pt}}p{" ++ width ++ + "\\columnwidth}") + colWidths aligns + let tableBody = text ("\\begin{tabular}{" ++ colDescriptors ++ "}") $$ + headers $$ text "\\hline" $$ vcat rows' $$ + text "\\end{tabular}" + let centered txt = text "\\begin{center}" $$ txt $$ text "\\end{center}" + addToHeader $ "\\usepackage{array}\n" ++ + "% This is needed because raggedright in table elements redefines \\\\:\n" ++ + "\\newcommand{\\PreserveBackslash}[1]{\\let\\temp=\\\\#1\\let\\\\=\\temp}\n" ++ + "\\let\\PBS=\\PreserveBackslash" + return $ if isEmpty captionText + then centered tableBody <> char '\n' + else text "\\begin{table}[h]" $$ centered tableBody $$ + inCmd "caption" captionText $$ text "\\end{table}\n" + +blockListToLaTeX :: [Block] -> State WriterState Doc +blockListToLaTeX lst = mapM blockToLaTeX lst >>= return . vcat + +tableRowToLaTeX :: [[Block]] -> State WriterState Doc +tableRowToLaTeX cols = mapM blockListToLaTeX cols >>= + return . ($$ text "\\\\") . foldl (\row item -> row $$ + (if isEmpty row then text "" else text " & ") <> item) empty + +listItemToLaTeX :: [Block] -> State WriterState Doc +listItemToLaTeX lst = blockListToLaTeX lst >>= return . (text "\\item" $$) . + (nest 2) + +defListItemToLaTeX :: ([Inline], [Block]) -> State WriterState Doc +defListItemToLaTeX (term, def) = do + term' <- inlineListToLaTeX $ deVerb term + def' <- blockListToLaTeX def + return $ text "\\item[" <> term' <> text "]" $$ def' + +-- | Convert list of inline elements to LaTeX. +inlineListToLaTeX :: [Inline] -- ^ Inlines to convert + -> State WriterState Doc +inlineListToLaTeX lst = mapM inlineToLaTeX lst >>= return . hcat + +isQuoted :: Inline -> Bool +isQuoted (Quoted _ _) = True +isQuoted Apostrophe = True +isQuoted _ = False + +-- | Convert inline element to LaTeX +inlineToLaTeX :: Inline -- ^ Inline to convert + -> State WriterState Doc +inlineToLaTeX (Emph lst) = + inlineListToLaTeX (deVerb lst) >>= return . inCmd "emph" +inlineToLaTeX (Strong lst) = + inlineListToLaTeX (deVerb lst) >>= return . inCmd "textbf" +inlineToLaTeX (Strikeout lst) = do + contents <- inlineListToLaTeX $ deVerb lst + addToHeader "\\usepackage[normalem]{ulem}" + return $ inCmd "sout" contents +inlineToLaTeX (Superscript lst) = + inlineListToLaTeX (deVerb lst) >>= return . inCmd "textsuperscript" +inlineToLaTeX (Subscript lst) = do + contents <- inlineListToLaTeX $ deVerb lst + -- oddly, latex includes \textsuperscript but not \textsubscript + -- so we have to define it (using a different name so as not to conflict with memoir class): + addToHeader "\\newcommand{\\textsubscr}[1]{\\ensuremath{_{\\scriptsize\\textrm{#1}}}}" + return $ inCmd "textsubscr" contents +inlineToLaTeX (SmallCaps lst) = + inlineListToLaTeX (deVerb lst) >>= return . inCmd "textsc" +inlineToLaTeX (Cite _ lst) = + inlineListToLaTeX lst +inlineToLaTeX (Code str) = do + st <- get + if stInNote st + then do addToHeader "\\usepackage{fancyvrb}" + else return () + let chr = ((enumFromTo '!' '~') \\ str) !! 0 + return $ text $ "\\verb" ++ [chr] ++ str ++ [chr] +inlineToLaTeX (Quoted SingleQuote lst) = do + contents <- inlineListToLaTeX lst + let s1 = if (not (null lst)) && (isQuoted (head lst)) + then text "\\," + else empty + let s2 = if (not (null lst)) && (isQuoted (last lst)) + then text "\\," + else empty + return $ char '`' <> s1 <> contents <> s2 <> char '\'' +inlineToLaTeX (Quoted DoubleQuote lst) = do + contents <- inlineListToLaTeX lst + let s1 = if (not (null lst)) && (isQuoted (head lst)) + then text "\\," + else empty + let s2 = if (not (null lst)) && (isQuoted (last lst)) + then text "\\," + else empty + return $ text "``" <> s1 <> contents <> s2 <> text "''" +inlineToLaTeX Apostrophe = return $ char '\'' +inlineToLaTeX EmDash = return $ text "---" +inlineToLaTeX EnDash = return $ text "--" +inlineToLaTeX Ellipses = return $ text "\\ldots{}" +inlineToLaTeX (Str str) = return $ text $ stringToLaTeX str +inlineToLaTeX (Math InlineMath str) = return $ char '$' <> text str <> char '$' +inlineToLaTeX (Math DisplayMath str) = return $ text "\\[" <> text str <> text "\\]" +inlineToLaTeX (TeX str) = return $ text str +inlineToLaTeX (HtmlInline _) = return empty +inlineToLaTeX (LineBreak) = return $ text "\\\\" +inlineToLaTeX Space = return $ char ' ' +inlineToLaTeX (Link txt (src, _)) = do + addToHeader "\\usepackage[breaklinks=true]{hyperref}" + case txt of + [Code x] | x == src -> -- autolink + do addToHeader "\\usepackage{url}" + return $ text $ "\\url{" ++ x ++ "}" + _ -> do contents <- inlineListToLaTeX $ deVerb txt + return $ text ("\\href{" ++ src ++ "}{") <> contents <> + char '}' +inlineToLaTeX (Image _ (source, _)) = do + addToHeader "\\usepackage{graphicx}" + return $ text $ "\\includegraphics{" ++ source ++ "}" +inlineToLaTeX (Note contents) = do + st <- get + put (st {stInNote = True}) + contents' <- blockListToLaTeX contents + modify (\s -> s {stInNote = False}) + let rawnote = stripTrailingNewlines $ render contents' + -- note: a \n before } is needed when note ends with a Verbatim environment + let optNewline = "\\end{Verbatim}" `isSuffixOf` rawnote + return $ text "\\footnote{" <> + text rawnote <> (if optNewline then char '\n' else empty) <> char '}' diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs new file mode 100644 index 000000000..210c7ed07 --- /dev/null +++ b/src/Text/Pandoc/Writers/Man.hs @@ -0,0 +1,301 @@ +{- +Copyright (C) 2007 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.Man + Copyright : Copyright (C) 2007 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to groff man page format. + +-} +module Text.Pandoc.Writers.Man ( writeMan) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Printf ( printf ) +import Data.List ( isPrefixOf, drop, nub, intersperse, intercalate ) +import Text.PrettyPrint.HughesPJ hiding ( Str ) +import Control.Monad.State + +type Notes = [[Block]] +type Preprocessors = [String] -- e.g. "t" for tbl +type WriterState = (Notes, Preprocessors) + +-- | Convert Pandoc to Man. +writeMan :: WriterOptions -> Pandoc -> String +writeMan opts document = render $ evalState (pandocToMan opts document) ([],[]) + +-- | Return groff man representation of document. +pandocToMan :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToMan opts (Pandoc meta blocks) = do + let before = writerIncludeBefore opts + let after = writerIncludeAfter opts + let before' = if null before then empty else text before + let after' = if null after then empty else text after + (head', foot) <- metaToMan opts meta + body <- blockListToMan opts blocks + (notes, preprocessors) <- get + let preamble = if null preprocessors || not (writerStandalone opts) + then empty + else text $ ".\\\" " ++ concat (nub preprocessors) + notes' <- notesToMan opts (reverse notes) + return $ preamble $$ head' $$ before' $$ body $$ notes' $$ foot $$ after' + +-- | Insert bibliographic information into Man header and footer. +metaToMan :: WriterOptions -- ^ Options, including Man header + -> Meta -- ^ Meta with bibliographic information + -> State WriterState (Doc, Doc) +metaToMan options (Meta title authors date) = do + titleText <- inlineListToMan options title + let (cmdName, rest) = break (== ' ') $ render titleText + let (title', section) = case reverse cmdName of + (')':d:'(':xs) | d `elem` ['0'..'9'] -> + (text (reverse xs), char d) + xs -> (text (reverse xs), doubleQuotes empty) + let extras = map (doubleQuotes . text . removeLeadingTrailingSpace) $ + splitBy '|' rest + let head' = (text ".TH") <+> title' <+> section <+> + doubleQuotes (text date) <+> hsep extras + let foot = case length authors of + 0 -> empty + 1 -> text ".SH AUTHOR" $$ (text $ intercalate ", " authors) + _ -> text ".SH AUTHORS" $$ (text $ intercalate ", " authors) + return $ if writerStandalone options + then (head', foot) + else (empty, empty) + +-- | Return man representation of notes. +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) >>= + return . (text ".SH NOTES" $$) . vcat + +-- | Return man representation of a note. +noteToMan :: WriterOptions -> Int -> [Block] -> State WriterState Doc +noteToMan opts num note = do + contents <- blockListToMan opts note + let marker = text "\n.SS [" <> text (show num) <> char ']' + return $ marker $$ contents + +-- | Association list of characters to escape. +manEscapes :: [(Char, String)] +manEscapes = [('\160', "\\ "), ('\'', "\\[aq]")] ++ backslashEscapes ".@\\" + +-- | Escape special characters for Man. +escapeString :: String -> String +escapeString = escapeStringUsing manEscapes + +-- | Escape a literal (code) section for Man. +escapeCode :: String -> String +escapeCode = escapeStringUsing (manEscapes ++ backslashEscapes "\t ") + +-- | Convert Pandoc block element to man. +blockToMan :: WriterOptions -- ^ Options + -> Block -- ^ Block element + -> State WriterState Doc +blockToMan _ Null = return empty +blockToMan opts (Plain inlines) = + wrapIfNeeded opts (inlineListToMan opts) inlines +blockToMan opts (Para inlines) = do + contents <- wrapIfNeeded opts (inlineListToMan opts) inlines + return $ text ".PP" $$ contents +blockToMan _ (RawHtml str) = return $ text str +blockToMan _ HorizontalRule = return $ text $ ".PP\n * * * * *" +blockToMan opts (Header level inlines) = do + contents <- inlineListToMan opts inlines + let heading = case level of + 1 -> ".SH " + _ -> ".SS " + return $ text heading <> contents +blockToMan _ (CodeBlock _ str) = return $ + text ".PP" $$ text "\\f[CR]" $$ + text ((unlines . map (" " ++) . lines) (escapeCode str)) <> text "\\f[]" +blockToMan opts (BlockQuote blocks) = do + contents <- blockListToMan opts blocks + return $ text ".RS" $$ contents $$ text ".RE" +blockToMan opts (Table caption alignments widths headers rows) = + let aligncode AlignLeft = "l" + aligncode AlignRight = "r" + aligncode AlignCenter = "c" + aligncode AlignDefault = "l" + in do + caption' <- inlineListToMan opts caption + modify (\(notes, preprocessors) -> (notes, "t":preprocessors)) + let iwidths = map (printf "w(%0.2fn)" . (70 *)) widths + -- 78n default width - 8n indent = 70n + let coldescriptions = text $ intercalate " " + (zipWith (\align width -> aligncode align ++ width) + alignments iwidths) ++ "." + colheadings <- mapM (blockListToMan opts) headers + let makeRow cols = text "T{" $$ + (vcat $ intersperse (text "T}@T{") cols) $$ + text "T}" + let colheadings' = makeRow colheadings + body <- mapM (\row -> do + cols <- mapM (blockListToMan opts) row + return $ makeRow cols) rows + return $ text ".PP" $$ caption' $$ + text ".TS" $$ text "tab(@);" $$ coldescriptions $$ + colheadings' $$ char '_' $$ vcat body $$ text ".TE" + +blockToMan opts (BulletList items) = do + contents <- mapM (bulletListItemToMan opts) items + return (vcat contents) +blockToMan opts (OrderedList attribs items) = do + 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 + return (vcat contents) +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 ((Plain first):rest) +bulletListItemToMan opts ((Plain first):rest) = do + 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'') +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 + -> Int -- ^ number of spaces to indent + -> [Block] -- ^ list item (list of blocks) + -> State WriterState Doc +orderedListItemToMan _ _ _ [] = return empty +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 + rest' <- blockListToMan opts rest + let num' = printf ("%" ++ show (indent - 1) ++ "s") num + let first'' = text (".IP \"" ++ num' ++ "\" " ++ show indent) $$ first' + let rest'' = if null rest + then empty + else text ".RS 4" $$ rest' $$ text ".RE" + return $ first'' $$ rest'' + +-- | Convert definition list item (label, list of blocks) to man. +definitionListItemToMan :: WriterOptions + -> ([Inline],[Block]) + -> State WriterState Doc +definitionListItemToMan opts (label, items) = do + labelText <- inlineListToMan opts label + contents <- if null items + then return empty + else do + let (first, rest) = case items of + ((Para x):y) -> (Plain x,y) + (x:y) -> (x,y) + [] -> error "items is null" + rest' <- mapM (\item -> blockToMan opts item) + rest >>= (return . vcat) + first' <- blockToMan opts first + return $ first' $$ text ".RS" $$ rest' $$ text ".RE" + return $ text ".TP\n.B " <> labelText $+$ contents + +-- | Convert list of Pandoc block elements to man. +blockListToMan :: WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> State WriterState Doc +blockListToMan opts blocks = + mapM (blockToMan opts) blocks >>= (return . vcat) + +-- | Convert list of Pandoc inline elements to man. +inlineListToMan :: WriterOptions -> [Inline] -> State WriterState Doc +inlineListToMan 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 + contents <- inlineListToMan opts lst + return $ text "\\f[I]" <> contents <> text "\\f[]" +inlineToMan opts (Strong lst) = do + contents <- inlineListToMan opts lst + return $ text "\\f[B]" <> contents <> text "\\f[]" +inlineToMan opts (Strikeout lst) = do + contents <- inlineListToMan opts lst + return $ text "[STRIKEOUT:" <> contents <> char ']' +inlineToMan opts (Superscript lst) = do + contents <- inlineListToMan opts lst + return $ char '^' <> contents <> char '^' +inlineToMan opts (Subscript lst) = do + contents <- inlineListToMan opts lst + return $ char '~' <> contents <> char '~' +inlineToMan opts (SmallCaps lst) = inlineListToMan opts lst -- not supported +inlineToMan opts (Quoted SingleQuote lst) = do + contents <- inlineListToMan opts lst + return $ char '`' <> contents <> char '\'' +inlineToMan opts (Quoted DoubleQuote lst) = do + contents <- inlineListToMan opts lst + return $ text "\\[lq]" <> contents <> text "\\[rq]" +inlineToMan opts (Cite _ lst) = + inlineListToMan opts lst +inlineToMan _ EmDash = return $ text "\\[em]" +inlineToMan _ EnDash = return $ text "\\[en]" +inlineToMan _ Apostrophe = return $ char '\'' +inlineToMan _ Ellipses = return $ text "\\&..." +inlineToMan _ (Code str) = + return $ text $ "\\f[B]" ++ escapeCode str ++ "\\f[]" +inlineToMan _ (Str str) = return $ text $ escapeString str +inlineToMan opts (Math InlineMath str) = inlineToMan opts (Code str) +inlineToMan opts (Math DisplayMath str) = do + contents <- inlineToMan opts (Code str) + return $ text ".RS" $$ contents $$ text ".RE" +inlineToMan _ (TeX _) = return empty +inlineToMan _ (HtmlInline str) = return $ text $ escapeCode str +inlineToMan _ (LineBreak) = return $ text "\n.PD 0\n.P\n.PD\n" +inlineToMan _ Space = return $ char ' ' +inlineToMan opts (Link txt (src, _)) = do + linktext <- inlineListToMan opts txt + let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src + return $ if txt == [Code srcSuffix] + then char '<' <> text srcSuffix <> char '>' + else linktext <> text " (" <> text src <> char ')' +inlineToMan opts (Image alternate (source, tit)) = do + 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)) + return $ char '[' <> text "IMAGE: " <> linkPart <> char ']' +inlineToMan _ (Note contents) = do + modify (\(notes, prep) -> (contents:notes, prep)) -- add to notes in state + (notes, _) <- get + let ref = show $ (length notes) + return $ char '[' <> text ref <> char ']' + diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs new file mode 100644 index 000000000..70d1f0c91 --- /dev/null +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -0,0 +1,396 @@ +{- +Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.Markdown + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to markdown-formatted plain text. + +Markdown: <http://daringfireball.net/projects/markdown/> +-} +module Text.Pandoc.Writers.Markdown ( writeMarkdown) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Pandoc.Blocks +import Text.ParserCombinators.Parsec ( parse, GenParser ) +import Data.List ( group, isPrefixOf, drop, find, intersperse, intercalate ) +import Text.PrettyPrint.HughesPJ hiding ( Str ) +import Control.Monad.State + +type Notes = [[Block]] +type Refs = KeyTable +type WriterState = (Notes, Refs) + +-- | Convert Pandoc to Markdown. +writeMarkdown :: WriterOptions -> Pandoc -> String +writeMarkdown opts document = + render $ evalState (pandocToMarkdown opts document) ([],[]) + +-- | Return markdown representation of document. +pandocToMarkdown :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToMarkdown opts (Pandoc meta blocks) = do + let before = writerIncludeBefore opts + let after = writerIncludeAfter opts + let before' = if null before then empty else text before + let after' = if null after then empty else text after + metaBlock <- metaToMarkdown opts meta + let head' = if writerStandalone opts + then metaBlock $+$ text (writerHeader opts) + else empty + let headerBlocks = filter isHeaderBlock blocks + let toc = if writerTableOfContents opts + then tableOfContents opts headerBlocks + else empty + body <- blockListToMarkdown opts blocks + (notes, _) <- get + notes' <- notesToMarkdown opts (reverse notes) + (_, refs) <- get -- note that the notes may contain refs + refs' <- keyTableToMarkdown opts (reverse refs) + return $ head' $+$ before' $+$ toc $+$ body $+$ text "" $+$ + notes' $+$ text "" $+$ refs' $+$ after' + +-- | Return markdown representation of reference key table. +keyTableToMarkdown :: WriterOptions -> KeyTable -> State WriterState Doc +keyTableToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat + +-- | 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 + let tit' = if null tit then empty else text $ " \"" ++ tit ++ "\"" + return $ text " " <> char '[' <> label' <> char ']' <> text ": " <> + text src <> tit' + +-- | Return markdown representation of notes. +notesToMarkdown :: WriterOptions -> [[Block]] -> State WriterState Doc +notesToMarkdown opts notes = + mapM (\(num, note) -> noteToMarkdown opts num note) (zip [1..] notes) >>= + return . vcat + +-- | Return markdown representation of a note. +noteToMarkdown :: WriterOptions -> Int -> [Block] -> State WriterState Doc +noteToMarkdown opts num blocks = do + contents <- blockListToMarkdown opts blocks + let marker = text "[^" <> text (show num) <> text "]:" + return $ hang' marker (writerTabStop opts) contents + +-- | Escape special characters for Markdown. +escapeString :: String -> String +escapeString = escapeStringUsing markdownEscapes + where markdownEscapes = backslashEscapes "`<\\*_^~" + +-- | Convert bibliographic information into Markdown header. +metaToMarkdown :: WriterOptions -> Meta -> State WriterState Doc +metaToMarkdown opts (Meta title authors date) = do + title' <- titleToMarkdown opts title + authors' <- authorsToMarkdown authors + date' <- dateToMarkdown date + return $ title' $+$ authors' $+$ date' + +titleToMarkdown :: WriterOptions -> [Inline] -> State WriterState Doc +titleToMarkdown _ [] = return empty +titleToMarkdown opts lst = do + contents <- inlineListToMarkdown opts lst + return $ text "% " <> contents + +authorsToMarkdown :: [String] -> State WriterState Doc +authorsToMarkdown [] = return empty +authorsToMarkdown lst = return $ + text "% " <> text (intercalate ", " (map escapeString lst)) + +dateToMarkdown :: String -> State WriterState Doc +dateToMarkdown [] = return empty +dateToMarkdown str = return $ text "% " <> text (escapeString str) + +-- | Construct table of contents from list of header blocks. +tableOfContents :: WriterOptions -> [Block] -> Doc +tableOfContents opts headers = + let opts' = opts { writerIgnoreNotes = True } + contents = BulletList $ map elementToListItem $ hierarchicalize headers + in evalState (blockToMarkdown opts' contents) ([],[]) + +-- | Converts an Element to a list item for a table of contents, +elementToListItem :: Element -> [Block] +elementToListItem (Blk _) = [] +elementToListItem (Sec headerText subsecs) = [Plain headerText] ++ + if null subsecs + then [] + else [BulletList $ map elementToListItem subsecs] + +-- | Ordered list start parser for use in Para below. +olMarker :: GenParser Char st Char +olMarker = do (start, style', delim) <- anyOrderedListMarker + if delim == Period && + (style' == UpperAlpha || (style' == UpperRoman && + start `elem` [1, 5, 10, 50, 100, 500, 1000])) + then spaceChar >> spaceChar + else spaceChar + +-- | True if string begins with an ordered list marker +beginsWithOrderedListMarker :: String -> Bool +beginsWithOrderedListMarker str = + case parse olMarker "para start" str of + Left _ -> False + Right _ -> True + +wrappedMarkdown :: WriterOptions -> [Inline] -> State WriterState Doc +wrappedMarkdown opts inlines = do + let chunks = splitBy LineBreak inlines + let chunks' = if null chunks + then [] + else (map (++ [Str " "]) $ init chunks) ++ [last chunks] + lns <- mapM (wrapIfNeeded opts (inlineListToMarkdown opts)) chunks' + return $ vcat lns + +-- | Convert Pandoc block element to markdown. +blockToMarkdown :: WriterOptions -- ^ Options + -> Block -- ^ Block element + -> State WriterState Doc +blockToMarkdown _ Null = return empty +blockToMarkdown opts (Plain inlines) = + wrappedMarkdown opts inlines +blockToMarkdown opts (Para inlines) = do + contents <- wrappedMarkdown opts inlines + -- escape if para starts with ordered list marker + let esc = if (not (writerStrictMarkdown opts)) && + beginsWithOrderedListMarker (render contents) + then char '\\' + else empty + return $ esc <> contents <> text "\n" +blockToMarkdown _ (RawHtml str) = return $ text str +blockToMarkdown _ HorizontalRule = return $ text "\n* * * * *\n" +blockToMarkdown opts (Header level inlines) = do + contents <- inlineListToMarkdown opts inlines + -- use setext style headers if in literate haskell mode. + -- ghc interprets '#' characters in column 1 as line number specifiers. + if writerLiterateHaskell opts + then let len = length $ render contents + in return $ contents <> text "\n" <> + case level of + 1 -> text $ replicate len '=' ++ "\n" + 2 -> text $ replicate len '-' ++ "\n" + _ -> empty + else return $ text ((replicate level '#') ++ " ") <> contents <> text "\n" +blockToMarkdown opts (CodeBlock (_,classes,_) str) | "haskell" `elem` classes && + writerLiterateHaskell opts = + return $ (vcat $ map (text "> " <>) $ map text (lines str)) <> text "\n" +blockToMarkdown opts (CodeBlock _ str) = return $ + (nest (writerTabStop opts) $ vcat $ map text (lines str)) <> text "\n" +blockToMarkdown opts (BlockQuote blocks) = do + -- 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 + then text . (" > " ++) + else text . ("> " ++) + contents <- blockListToMarkdown opts blocks + return $ (vcat $ map leader $ lines $ render contents) <> + text "\n" +blockToMarkdown opts (Table caption aligns widths headers rows) = do + caption' <- inlineListToMarkdown opts caption + let caption'' = if null caption + then empty + else text "" $+$ (text "Table: " <> caption') + headers' <- mapM (blockListToMarkdown opts) headers + let widthsInChars = map (floor . (78 *)) widths + let alignHeader alignment = case alignment of + AlignLeft -> leftAlignBlock + AlignCenter -> centerAlignBlock + AlignRight -> rightAlignBlock + AlignDefault -> leftAlignBlock + let makeRow = hsepBlocks . (zipWith alignHeader aligns) . + (zipWith docToBlock widthsInChars) + let head' = makeRow headers' + rows' <- mapM (\row -> do cols <- mapM (blockListToMarkdown opts) row + return $ makeRow cols) rows + let maxRowHeight = maximum $ map heightOfBlock (head':rows') + let isMultilineTable = maxRowHeight > 1 + let underline = hsep $ + map (\width -> text $ replicate width '-') widthsInChars + let border = if isMultilineTable + then text $ replicate (sum widthsInChars + (length widthsInChars - 1)) '-' + else empty + let spacer = if isMultilineTable + then text "" + else empty + let body = vcat $ intersperse spacer $ map blockToDoc rows' + return $ (nest 2 $ border $+$ (blockToDoc head') $+$ underline $+$ body $+$ + border $+$ caption'') <> text "\n" +blockToMarkdown opts (BulletList items) = do + contents <- mapM (bulletListItemToMarkdown opts) items + return $ (vcat contents) <> text "\n" +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 $ (vcat contents) <> text "\n" +blockToMarkdown opts (DefinitionList items) = do + contents <- mapM (definitionListItemToMarkdown opts) items + return $ (vcat contents) <> text "\n" + +-- | Convert bullet list item (list of blocks) to markdown. +bulletListItemToMarkdown :: WriterOptions -> [Block] -> State WriterState Doc +bulletListItemToMarkdown opts items = do + contents <- blockListToMarkdown opts items + return $ hang' (text "- ") (writerTabStop opts) contents + +-- | Convert ordered list item (a list of blocks) to markdown. +orderedListItemToMarkdown :: WriterOptions -- ^ options + -> String -- ^ list item marker + -> [Block] -- ^ list item (list of blocks) + -> State WriterState Doc +orderedListItemToMarkdown opts marker items = do + contents <- blockListToMarkdown opts items + return $ hsep [nest (min (3 - length marker) 0) (text marker), + nest (writerTabStop opts) contents] + +-- | Convert definition list item (label, list of blocks) to markdown. +definitionListItemToMarkdown :: WriterOptions + -> ([Inline],[Block]) + -> State WriterState Doc +definitionListItemToMarkdown opts (label, items) = do + labelText <- inlineListToMarkdown opts label + let tabStop = writerTabStop opts + let leader = char ':' + contents <- mapM (\item -> blockToMarkdown opts item >>= + (\txt -> return (leader $$ nest tabStop txt))) + items >>= return . vcat + return $ labelText $+$ contents + +-- | Convert list of Pandoc block elements to markdown. +blockListToMarkdown :: WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> State WriterState Doc +blockListToMarkdown opts blocks = + mapM (blockToMarkdown opts) blocks >>= return . vcat + +-- | Get reference for target; if none exists, create unique one and return. +-- Prefer label if possible; otherwise, generate a unique key. +getReference :: [Inline] -> Target -> State WriterState [Inline] +getReference label (src, tit) = do + (_,refs) <- get + case find ((== (src, tit)) . snd) refs of + Just (ref, _) -> return ref + Nothing -> do + let label' = case find ((== label) . fst) refs of + Just _ -> -- label is used; generate numerical label + case find (\n -> not (any (== [Str (show n)]) + (map fst refs))) [1..(10000 :: Integer)] of + Just x -> [Str (show x)] + Nothing -> error "no unique label" + Nothing -> label + modify (\(notes, refs') -> (notes, (label', (src,tit)):refs')) + return label' + +-- | Convert list of Pandoc inline elements to markdown. +inlineListToMarkdown :: WriterOptions -> [Inline] -> State WriterState Doc +inlineListToMarkdown opts lst = + mapM (inlineToMarkdown opts) lst >>= return . hcat + +-- | Convert Pandoc inline element to markdown. +inlineToMarkdown :: WriterOptions -> Inline -> State WriterState Doc +inlineToMarkdown opts (Emph lst) = do + contents <- inlineListToMarkdown opts lst + return $ char '*' <> contents <> char '*' +inlineToMarkdown opts (Strong lst) = do + contents <- inlineListToMarkdown opts lst + return $ text "**" <> contents <> text "**" +inlineToMarkdown opts (Strikeout lst) = do + contents <- inlineListToMarkdown opts lst + return $ text "~~" <> contents <> text "~~" +inlineToMarkdown opts (Superscript lst) = do + contents <- inlineListToMarkdown opts lst + let contents' = text $ substitute " " "\\ " $ render contents + return $ char '^' <> contents' <> char '^' +inlineToMarkdown opts (Subscript lst) = do + contents <- inlineListToMarkdown opts lst + let contents' = text $ substitute " " "\\ " $ render contents + return $ char '~' <> contents' <> char '~' +inlineToMarkdown opts (SmallCaps lst) = inlineListToMarkdown opts lst +inlineToMarkdown opts (Quoted SingleQuote lst) = do + contents <- inlineListToMarkdown opts lst + return $ char '\'' <> contents <> char '\'' +inlineToMarkdown opts (Quoted DoubleQuote lst) = do + contents <- inlineListToMarkdown opts lst + return $ char '"' <> contents <> char '"' +inlineToMarkdown _ EmDash = return $ text "--" +inlineToMarkdown _ EnDash = return $ char '-' +inlineToMarkdown _ Apostrophe = return $ char '\'' +inlineToMarkdown _ Ellipses = return $ text "..." +inlineToMarkdown _ (Code str) = + let tickGroups = filter (\s -> '`' `elem` s) $ group str + longest = if null tickGroups + then 0 + else maximum $ map length tickGroups + marker = replicate (longest + 1) '`' + spacer = if (longest == 0) then "" else " " in + return $ text (marker ++ spacer ++ str ++ spacer ++ marker) +inlineToMarkdown _ (Str str) = return $ text $ escapeString str +inlineToMarkdown _ (Math InlineMath str) = return $ char '$' <> text str <> char '$' +inlineToMarkdown _ (Math DisplayMath str) = return $ text "$$" <> text str <> text "$$" +inlineToMarkdown _ (TeX str) = return $ text str +inlineToMarkdown _ (HtmlInline str) = return $ text str +inlineToMarkdown _ (LineBreak) = return $ text " \n" +inlineToMarkdown _ Space = return $ char ' ' +inlineToMarkdown _ (Cite cits _ ) = do + let format (a,b) xs = text a <> + (if b /= [] then char '@' else empty) <> + text b <> + (if isEmpty xs then empty else text "; ") <> + xs + return $ char '[' <> foldr format empty cits <> char ']' +inlineToMarkdown opts (Link txt (src, tit)) = do + linktext <- inlineListToMarkdown opts txt + let linktitle = if null tit then empty else text $ " \"" ++ tit ++ "\"" + let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src + let useRefLinks = writerReferenceLinks opts + let useAuto = null tit && txt == [Code srcSuffix] + ref <- if useRefLinks then getReference txt (src, tit) else return [] + reftext <- inlineListToMarkdown opts ref + return $ if useAuto + then char '<' <> text srcSuffix <> char '>' + else if useRefLinks + then let first = char '[' <> linktext <> char ']' + second = if txt == ref + then text "[]" + else char '[' <> reftext <> char ']' + in first <> second + else char '[' <> linktext <> char ']' <> + char '(' <> text src <> linktitle <> char ')' +inlineToMarkdown opts (Image alternate (source, tit)) = do + let txt = if (null alternate) || (alternate == [Str ""]) || + (alternate == [Str source]) -- to prevent autolinks + then [Str "image"] + else alternate + linkPart <- inlineToMarkdown opts (Link txt (source, tit)) + return $ char '!' <> linkPart +inlineToMarkdown _ (Note contents) = do + modify (\(notes, refs) -> (contents:notes, refs)) -- add to notes in state + (notes, _) <- get + let ref = show $ (length notes) + return $ text "[^" <> text ref <> char ']' diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs new file mode 100644 index 000000000..c5f6b3bf1 --- /dev/null +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -0,0 +1,396 @@ +{- +Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.MediaWiki + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to MediaWiki markup. + +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.XML ( escapeStringForXML ) +import Data.List ( intersect ) +import Network.URI ( isURI ) +import Control.Monad.State + +data WriterState = WriterState { + stNotes :: Bool -- True if there are notes + , stListLevel :: [Char] -- String at beginning of list items, e.g. "**" + , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list + } + +-- | Convert Pandoc to MediaWiki. +writeMediaWiki :: WriterOptions -> Pandoc -> String +writeMediaWiki opts document = + evalState (pandocToMediaWiki opts document) + (WriterState { stNotes = False, stListLevel = [], stUseTags = False }) + +-- | Return MediaWiki representation of document. +pandocToMediaWiki :: WriterOptions -> Pandoc -> State WriterState String +pandocToMediaWiki opts (Pandoc _ blocks) = do + let before = writerIncludeBefore opts + let after = writerIncludeAfter opts + let head' = if writerStandalone opts + then writerHeader opts + else "" + let toc = if writerTableOfContents opts + then "__TOC__\n" + else "" + body <- blockListToMediaWiki opts blocks + notesExist <- get >>= return . stNotes + let notes = if notesExist + then "\n== Notes ==\n<references />" + else "" + return $ head' ++ before ++ toc ++ body ++ after ++ notes + +-- | Escape special characters for MediaWiki. +escapeString :: String -> String +escapeString = escapeStringForXML + +-- | Convert Pandoc block element to MediaWiki. +blockToMediaWiki :: WriterOptions -- ^ Options + -> Block -- ^ Block element + -> State WriterState String + +blockToMediaWiki _ Null = return "" + +blockToMediaWiki opts (Plain inlines) = + inlineListToMediaWiki opts inlines + +blockToMediaWiki opts (Para inlines) = do + useTags <- get >>= return . stUseTags + listLevel <- get >>= return . stListLevel + contents <- inlineListToMediaWiki opts inlines + return $ if useTags + then "<p>" ++ contents ++ "</p>" + else contents ++ if null listLevel then "\n" else "" + +blockToMediaWiki _ (RawHtml str) = return str + +blockToMediaWiki _ HorizontalRule = return "\n-----\n" + +blockToMediaWiki opts (Header level inlines) = do + contents <- inlineListToMediaWiki opts inlines + let eqs = replicate (level + 1) '=' + return $ eqs ++ " " ++ contents ++ " " ++ eqs ++ "\n" + +blockToMediaWiki _ (CodeBlock (_,classes,_) str) = do + let at = classes `intersect` ["actionscript", "ada", "apache", "applescript", "asm", "asp", + "autoit", "bash", "blitzbasic", "bnf", "c", "c_mac", "caddcl", "cadlisp", "cfdg", "cfm", + "cpp", "cpp-qt", "csharp", "css", "d", "delphi", "diff", "div", "dos", "eiffel", "fortran", + "freebasic", "gml", "groovy", "html4strict", "idl", "ini", "inno", "io", "java", "java5", + "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", + "visualfoxpro", "winbatch", "xml", "xpp", "z80"] + let (beg, end) = if null at + then ("<pre" ++ if null classes then ">" else " class=\"" ++ unwords classes ++ "\">", "</pre>") + else ("<source lang=\"" ++ head at ++ "\">", "</source>") + return $ beg ++ escapeString str ++ end + +blockToMediaWiki opts (BlockQuote blocks) = do + contents <- blockListToMediaWiki opts blocks + return $ "<blockquote>" ++ contents ++ "</blockquote>" + +blockToMediaWiki opts (Table caption aligns widths headers rows) = do + let alignStrings = map alignmentToString aligns + captionDoc <- if null caption + then return "" + else do + c <- inlineListToMediaWiki opts caption + return $ "<caption>" ++ c ++ "</caption>" + colHeads <- colHeadsToMediaWiki opts alignStrings widths headers + rows' <- mapM (tableRowToMediaWiki opts alignStrings) rows + return $ "<table>\n" ++ captionDoc ++ colHeads ++ vcat rows' ++ "\n</table>" + +blockToMediaWiki opts x@(BulletList items) = do + oldUseTags <- get >>= return . stUseTags + let useTags = oldUseTags || not (isSimpleList x) + if useTags + then do + modify $ \s -> s { stUseTags = True } + contents <- mapM (listItemToMediaWiki opts) items + modify $ \s -> s { stUseTags = oldUseTags } + return $ "<ul>\n" ++ vcat contents ++ "</ul>\n" + else do + modify $ \s -> s { stListLevel = stListLevel s ++ "*" } + contents <- mapM (listItemToMediaWiki opts) items + modify $ \s -> s { stListLevel = init (stListLevel s) } + return $ vcat contents + +blockToMediaWiki opts x@(OrderedList attribs items) = do + oldUseTags <- get >>= return . stUseTags + let useTags = oldUseTags || not (isSimpleList x) + if useTags + then do + modify $ \s -> s { stUseTags = True } + contents <- mapM (listItemToMediaWiki opts) items + modify $ \s -> s { stUseTags = oldUseTags } + return $ "<ol" ++ listAttribsToString attribs ++ ">\n" ++ vcat contents ++ "</ol>\n" + else do + modify $ \s -> s { stListLevel = stListLevel s ++ "#" } + contents <- mapM (listItemToMediaWiki opts) items + modify $ \s -> s { stListLevel = init (stListLevel s) } + return $ vcat contents + +blockToMediaWiki opts x@(DefinitionList items) = do + oldUseTags <- get >>= return . stUseTags + let useTags = oldUseTags || not (isSimpleList x) + if useTags + then do + modify $ \s -> s { stUseTags = True } + contents <- mapM (definitionListItemToMediaWiki opts) items + modify $ \s -> s { stUseTags = oldUseTags } + return $ "<dl>\n" ++ vcat contents ++ "</dl>\n" + else do + modify $ \s -> s { stListLevel = stListLevel s ++ ";" } + contents <- mapM (definitionListItemToMediaWiki opts) items + modify $ \s -> s { stListLevel = init (stListLevel s) } + return $ vcat contents + +-- Auxiliary functions for lists: + +-- | Convert ordered list attributes to HTML attribute string +listAttribsToString :: ListAttributes -> String +listAttribsToString (startnum, numstyle, _) = + let numstyle' = camelCaseToHyphenated $ show numstyle + in (if startnum /= 1 + then " start=\"" ++ show startnum ++ "\"" + else "") ++ + (if numstyle /= DefaultStyle + then " style=\"list-style-type: " ++ numstyle' ++ ";\"" + else "") + +-- | Convert bullet or ordered list item (list of blocks) to MediaWiki. +listItemToMediaWiki :: WriterOptions -> [Block] -> State WriterState String +listItemToMediaWiki opts items = do + contents <- blockListToMediaWiki opts items + useTags <- get >>= return . stUseTags + if useTags + then return $ "<li>" ++ contents ++ "</li>" + else do + marker <- get >>= return . stListLevel + return $ marker ++ " " ++ contents + +-- | Convert definition list item (label, list of blocks) to MediaWiki. +definitionListItemToMediaWiki :: WriterOptions + -> ([Inline],[Block]) + -> State WriterState String +definitionListItemToMediaWiki opts (label, items) = do + labelText <- inlineListToMediaWiki opts label + contents <- blockListToMediaWiki opts items + useTags <- get >>= return . stUseTags + if useTags + then return $ "<dt>" ++ labelText ++ "</dt>\n<dd>" ++ contents ++ "</dd>" + else do + marker <- get >>= return . stListLevel + return $ marker ++ " " ++ labelText ++ "\n" ++ (init marker ++ ": ") ++ contents + +-- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed. +isSimpleList :: Block -> Bool +isSimpleList x = + case x of + BulletList items -> all isSimpleListItem items + OrderedList (num, sty, _) items -> all isSimpleListItem items && + num == 1 && sty `elem` [DefaultStyle, Decimal] + DefinitionList items -> all isSimpleListItem $ map snd items + _ -> False + +-- | True if list item can be handled with the simple wiki syntax. False if +-- HTML tags will be needed. +isSimpleListItem :: [Block] -> Bool +isSimpleListItem [] = True +isSimpleListItem [x] = + case x of + Plain _ -> True + Para _ -> True + BulletList _ -> isSimpleList x + OrderedList _ _ -> isSimpleList x + DefinitionList _ -> isSimpleList x + _ -> False +isSimpleListItem [x, y] | isPlainOrPara x = + case y of + BulletList _ -> isSimpleList y + OrderedList _ _ -> isSimpleList y + DefinitionList _ -> isSimpleList y + _ -> False +isSimpleListItem _ = False + +isPlainOrPara :: Block -> Bool +isPlainOrPara (Plain _) = True +isPlainOrPara (Para _) = True +isPlainOrPara _ = False + +tr :: String -> String +tr x = "<tr>\n" ++ x ++ "\n</tr>" + +-- | Concatenates strings with line breaks between them. +vcat :: [String] -> String +vcat [] = "" +vcat [x] = x +vcat (x:xs) = x ++ "\n" ++ vcat xs + +-- Auxiliary functions for tables: + +colHeadsToMediaWiki :: WriterOptions + -> [[Char]] + -> [Double] + -> [[Block]] + -> State WriterState String +colHeadsToMediaWiki opts alignStrings widths headers = do + heads <- sequence $ zipWith3 + (\alignment columnwidth item -> tableItemToMediaWiki opts "th" alignment columnwidth item) + alignStrings widths headers + return $ tr $ vcat heads + +alignmentToString :: Alignment -> [Char] +alignmentToString alignment = case alignment of + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" + AlignDefault -> "left" + +tableRowToMediaWiki :: WriterOptions + -> [[Char]] + -> [[Block]] + -> State WriterState String +tableRowToMediaWiki opts aligns columns = + (sequence $ zipWith3 (tableItemToMediaWiki opts "td") aligns (repeat 0) columns) >>= + return . tr . vcat + +tableItemToMediaWiki :: WriterOptions + -> [Char] + -> [Char] + -> Double + -> [Block] + -> State WriterState String +tableItemToMediaWiki opts tag' align' width' item = do + contents <- blockListToMediaWiki opts item + let attrib = " align=\"" ++ align' ++ "\"" ++ + if width' /= 0 + then " style=\"width: " ++ (show (truncate (100 * width') :: Integer)) ++ "%;\"" + else "" + return $ "<" ++ tag' ++ attrib ++ ">" ++ contents ++ "</" ++ tag' ++ ">" + +-- | Convert list of Pandoc block elements to MediaWiki. +blockListToMediaWiki :: WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> State WriterState String +blockListToMediaWiki opts blocks = + mapM (blockToMediaWiki opts) blocks >>= return . vcat + +-- | Convert list of Pandoc inline elements to MediaWiki. +inlineListToMediaWiki :: WriterOptions -> [Inline] -> State WriterState String +inlineListToMediaWiki opts lst = + mapM (inlineToMediaWiki opts) lst >>= return . concat + +-- | Convert Pandoc inline element to MediaWiki. +inlineToMediaWiki :: WriterOptions -> Inline -> State WriterState String + +inlineToMediaWiki opts (Emph lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "''" ++ contents ++ "''" + +inlineToMediaWiki opts (Strong lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "'''" ++ contents ++ "'''" + +inlineToMediaWiki opts (Strikeout lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "<s>" ++ contents ++ "</s>" + +inlineToMediaWiki opts (Superscript lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "<sup>" ++ contents ++ "</sup>" + +inlineToMediaWiki opts (Subscript lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "<sub>" ++ contents ++ "</sub>" + +inlineToMediaWiki opts (SmallCaps lst) = inlineListToMediaWiki opts lst + +inlineToMediaWiki opts (Quoted SingleQuote lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "‘" ++ contents ++ "’" + +inlineToMediaWiki opts (Quoted DoubleQuote lst) = do + contents <- inlineListToMediaWiki opts lst + return $ "“" ++ contents ++ "”" + +inlineToMediaWiki opts (Cite _ lst) = inlineListToMediaWiki opts lst + +inlineToMediaWiki _ EmDash = return "—" + +inlineToMediaWiki _ EnDash = return "–" + +inlineToMediaWiki _ Apostrophe = return "’" + +inlineToMediaWiki _ Ellipses = return "…" + +inlineToMediaWiki _ (Code str) = + return $ "<tt>" ++ (escapeString str) ++ "</tt>" + +inlineToMediaWiki _ (Str str) = return $ escapeString str + +inlineToMediaWiki _ (Math _ str) = return $ "<math>" ++ str ++ "</math>" + -- note: str should NOT be escaped + +inlineToMediaWiki _ (TeX _) = return "" + +inlineToMediaWiki _ (HtmlInline str) = return str + +inlineToMediaWiki _ (LineBreak) = return "<br />\n" + +inlineToMediaWiki _ Space = return " " + +inlineToMediaWiki opts (Link txt (src, _)) = do + link <- inlineListToMediaWiki opts txt + let useAuto = txt == [Code src] + let src' = if isURI src + then src + else if take 1 src == "/" + then "http://{{SERVERNAME}}" ++ src + else "http://{{SERVERNAME}}/" ++ src + return $ if useAuto + then src' + else "[" ++ src' ++ " " ++ link ++ "]" + +inlineToMediaWiki opts (Image alt (source, tit)) = do + alt' <- inlineListToMediaWiki opts alt + let txt = if (null tit) + then if null alt + then "" + else "|" ++ alt' + else "|" ++ tit + return $ "[[Image:" ++ source ++ txt ++ "]]" + +inlineToMediaWiki opts (Note contents) = do + contents' <- blockListToMediaWiki opts contents + modify (\s -> s { stNotes = True }) + return $ "<ref>" ++ contents' ++ "</ref>" + -- note - may not work for notes with multiple blocks diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs new file mode 100644 index 000000000..52438f81e --- /dev/null +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -0,0 +1,568 @@ +{-# LANGUAGE PatternGuards #-} +{- +Copyright (C) 2008 Andrea Rossato <andrea.rossato@ing.unitn.it> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.OpenDocument + Copyright : Copyright (C) 2008 Andrea Rossato + License : GNU GPL, version 2 or above + + Maintainer : Andrea Rossato <andrea.rossato@ing.unitn.it> + Stability : alpha + Portability : portable + +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.XML +import Text.Pandoc.Readers.TeXMath +import Text.PrettyPrint.HughesPJ hiding ( Str ) +import Text.Printf ( printf ) +import Control.Applicative ( (<$>) ) +import Control.Arrow ( (***), (>>>) ) +import Control.Monad.State hiding ( when ) +import Data.Char (chr) +import Data.List (intercalate) + +-- | Auxiliary function to convert Plain block to Para. +plainToPara :: Block -> Block +plainToPara (Plain x) = Para x +plainToPara x = x + +-- +-- OpenDocument writer +-- + +data WriterState = + WriterState { stNotes :: [Doc] + , stTableStyles :: [Doc] + , stParaStyles :: [Doc] + , stListStyles :: [(Int, [Doc])] + , stTextStyles :: [Doc] + , stTextStyleAttr :: [(TextStyle,[(String,String)])] + , stIndentPara :: Int + , stInDefinition :: Bool + , stTight :: Bool + } + +defaultWriterState :: WriterState +defaultWriterState = + WriterState { stNotes = [] + , stTableStyles = [] + , stParaStyles = [] + , stListStyles = [] + , stTextStyles = [] + , stTextStyleAttr = [] + , stIndentPara = 0 + , stInDefinition = False + , stTight = False + } + +when :: Bool -> Doc -> Doc +when p a = if p then a else empty + +addTableStyle :: Doc -> State WriterState () +addTableStyle i = modify $ \s -> s { stTableStyles = i : stTableStyles s } + +addNote :: Doc -> State WriterState () +addNote i = modify $ \s -> s { stNotes = i : stNotes s } + +addParaStyle :: Doc -> State WriterState () +addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s } + +addTextStyle :: Doc -> State WriterState () +addTextStyle i = modify $ \s -> s { stTextStyles = i : stTextStyles s } + +addTextStyleAttr :: (TextStyle, [(String,String)]) -> State WriterState () +addTextStyleAttr i = modify $ \s -> s { stTextStyleAttr = i : stTextStyleAttr s } + +rmTextStyleAttr :: State WriterState () +rmTextStyleAttr = modify $ \s -> s { stTextStyleAttr = rmHead (stTextStyleAttr s) } + where rmHead l = if l /= [] then tail l else [] + +increaseIndent :: State WriterState () +increaseIndent = modify $ \s -> s { stIndentPara = 1 + stIndentPara s } + +resetIndent :: State WriterState () +resetIndent = modify $ \s -> s { stIndentPara = (stIndentPara s) - 1 } + +inTightList :: State WriterState a -> State WriterState a +inTightList f = modify (\s -> s { stTight = True }) >> f >>= \r -> + modify (\s -> s { stTight = False }) >> return r + +setInDefinitionList :: Bool -> State WriterState () +setInDefinitionList b = modify $ \s -> s { stInDefinition = b } + +inParagraphTags :: Doc -> Doc +inParagraphTags = inTags False "text:p" [("text:style-name", "Text_20_body")] + +inParagraphTagsWithStyle :: String -> Doc -> Doc +inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)] + +inSpanTags :: String -> Doc -> Doc +inSpanTags s = inTags False "text:span" [("text:style-name",s)] + +withTextStyle :: TextStyle -> State WriterState a -> State WriterState a +withTextStyle s f = addTextStyleAttr (s,textStyleAttr s) >> + f >>= \r -> rmTextStyleAttr >> return r + +inTextStyle :: Doc -> State WriterState Doc +inTextStyle d = do + at <- gets stTextStyleAttr + if at == [] + then return d + else do + tn <- (+) 1 . length <$> gets stTextStyles + addTextStyle $ inTags False "style:style" [("style:name" , "T" ++ show tn) + ,("style:family", "text" )] + $ selfClosingTag "style:text-properties" (concatMap snd at) + return $ inTags False "text:span" [("text:style-name","T" ++ show tn)] d + +inHeaderTags :: Int -> Doc -> Doc +inHeaderTags i = inTags False "text:h" [ ("text:style-name", "Heading_20_" ++ show i) + , ("text:outline-level", show i)] + +inQuotes :: QuoteType -> Doc -> Doc +inQuotes SingleQuote s = text "‘" <> s <> text "’" +inQuotes DoubleQuote s = text "“" <> s <> text "”" + +handleSpaces :: String -> Doc +handleSpaces s + | ( ' ':_) <- s = genTag s + | ('\t':x) <- s = selfClosingTag "text:tab" [] <> rm x + | otherwise = rm s + where + genTag = span (==' ') >>> tag . length *** rm >>> uncurry (<>) + tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", show n)] + rm ( ' ':xs) = char ' ' <> genTag xs + rm ('\t':xs) = selfClosingTag "text:tab" [] <> genTag xs + rm ( x:xs) = char x <> rm xs + rm [] = empty + +-- | Convert list of authors to a docbook <author> section +authorToOpenDocument :: [Char] -> Doc +authorToOpenDocument name = + if ',' `elem` name + then -- last name first + let (lastname, rest) = break (==',') name + firstname = removeLeadingSpace rest + in inParagraphTagsWithStyle "Author" $ + (text $ escapeStringForXML firstname) <+> + (text $ escapeStringForXML lastname) + else -- last name last + let namewords = words name + lengthname = length namewords + (firstname, lastname) = case lengthname of + 0 -> ("","") + 1 -> ("", name) + n -> (intercalate " " (take (n-1) namewords), last namewords) + in inParagraphTagsWithStyle "Author" $ + (text $ escapeStringForXML firstname) <+> + (text $ escapeStringForXML lastname) + +-- | Convert Pandoc document to string in OpenDocument format. +writeOpenDocument :: WriterOptions -> Pandoc -> String +writeOpenDocument opts (Pandoc (Meta title authors date) blocks) = + let root = inTags True "office:document-content" openDocumentNameSpaces + header = when (writerStandalone opts) $ text (writerHeader opts) + title' = case runState (wrap opts title) defaultWriterState of + (t,_) -> if isEmpty t then empty else inHeaderTags 1 t + authors' = when (authors /= []) $ vcat (map authorToOpenDocument authors) + date' = when (date /= []) $ + inParagraphTagsWithStyle "Date" (text $ escapeStringForXML date) + meta = when (writerStandalone opts) $ title' $$ authors' $$ date' + before = writerIncludeBefore opts + after = writerIncludeAfter opts + (doc, s) = runState (blocksToOpenDocument opts blocks) defaultWriterState + body = (if null before then empty else text before) $$ + doc $$ + (if null after then empty else text after) + body' = if writerStandalone opts + then inTagsIndented "office:body" $ + inTagsIndented "office:text" (meta $$ body) + else body + styles = stTableStyles s ++ stParaStyles s ++ stTextStyles s + listStyle (n,l) = inTags True "text:list-style" [("style:name", "L" ++ show n)] (vcat l) + listStyles = map listStyle (stListStyles s) + in render $ header $$ root (generateStyles (styles ++ listStyles) $$ body' $$ text "") + +withParagraphStyle :: WriterOptions -> String -> [Block] -> State WriterState Doc +withParagraphStyle o s (b:bs) + | Para l <- b = go =<< inParagraphTagsWithStyle s <$> inlinesToOpenDocument o l + | otherwise = go =<< blockToOpenDocument o b + where go i = ($$) i <$> withParagraphStyle o s bs +withParagraphStyle _ _ [] = return empty + +inPreformattedTags :: String -> State WriterState Doc +inPreformattedTags s = do + n <- paraStyle "Preformatted_20_Text" [] + return . inParagraphTagsWithStyle ("P" ++ show n) . handleSpaces $ s + +orderedListToOpenDocument :: WriterOptions -> Int -> [[Block]] -> State WriterState Doc +orderedListToOpenDocument o pn bs = + vcat . map (inTagsIndented "text:list-item") <$> + mapM (orderedItemToOpenDocument o pn . map plainToPara) bs + +orderedItemToOpenDocument :: WriterOptions -> Int -> [Block] -> State WriterState Doc +orderedItemToOpenDocument o n (b:bs) + | OrderedList a l <- b = newLevel a l + | Para l <- b = go =<< inParagraphTagsWithStyle ("P" ++ show n) <$> inlinesToOpenDocument o l + | otherwise = go =<< blockToOpenDocument o b + where + go i = ($$) i <$> orderedItemToOpenDocument o n bs + newLevel a l = do + nn <- length <$> gets stParaStyles + ls <- head <$> gets stListStyles + modify $ \s -> s { stListStyles = orderedListLevelStyle a ls : tail (stListStyles s) } + inTagsIndented "text:list" <$> orderedListToOpenDocument o nn l +orderedItemToOpenDocument _ _ [] = return empty + +isTightList :: [[Block]] -> Bool +isTightList [] = False +isTightList (b:_) + | Plain {} : _ <- b = True + | otherwise = False + +newOrderedListStyle :: Bool -> ListAttributes -> State WriterState (Int,Int) +newOrderedListStyle b a = do + ln <- (+) 1 . length <$> gets stListStyles + let nbs = orderedListLevelStyle a (ln, []) + pn <- if b then inTightList (paraListStyle ln) else paraListStyle ln + modify $ \s -> s { stListStyles = nbs : stListStyles s } + return (ln,pn) + +bulletListToOpenDocument :: WriterOptions -> [[Block]] -> State WriterState Doc +bulletListToOpenDocument o b = do + ln <- (+) 1 . length <$> gets stListStyles + (pn,ns) <- if isTightList b then inTightList (bulletListStyle ln) else bulletListStyle ln + modify $ \s -> s { stListStyles = ns : stListStyles s } + is <- listItemsToOpenDocument ("P" ++ show pn) o b + return $ inTags True "text:list" [("text:style-name", "L" ++ show ln)] is + +listItemsToOpenDocument :: String -> WriterOptions -> [[Block]] -> State WriterState Doc +listItemsToOpenDocument s o is = + vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is + +deflistItemToOpenDocument :: WriterOptions -> ([Inline],[Block]) -> State WriterState Doc +deflistItemToOpenDocument o (t,d) = do + let ts = if isTightList [d] + then "Definition_20_Term_20_Tight" else "Definition_20_Term" + ds = if isTightList [d] + then "Definition_20_Definition_20_Tight" else "Definition_20_Definition" + t' <- withParagraphStyle o ts [Para t] + d' <- withParagraphStyle o ds (map plainToPara d) + return $ t' $$ d' + +inBlockQuote :: WriterOptions -> Int -> [Block] -> State WriterState Doc +inBlockQuote o i (b:bs) + | BlockQuote l <- b = do increaseIndent + ni <- paraStyle "Quotations" [] + go =<< inBlockQuote o ni (map plainToPara l) + | Para l <- b = do go =<< inParagraphTagsWithStyle ("P" ++ show i) <$> inlinesToOpenDocument o l + | otherwise = do go =<< blockToOpenDocument o b + where go block = ($$) block <$> inBlockQuote o i bs +inBlockQuote _ _ [] = resetIndent >> return empty + +-- | Convert a list of Pandoc blocks to OpenDocument. +blocksToOpenDocument :: WriterOptions -> [Block] -> State WriterState Doc +blocksToOpenDocument o b = vcat <$> mapM (blockToOpenDocument o) b + +-- | Convert a Pandoc block element to OpenDocument. +blockToOpenDocument :: WriterOptions -> Block -> State WriterState Doc +blockToOpenDocument o bs + | Plain b <- bs = inParagraphTags <$> wrap o b + | Para b <- bs = inParagraphTags <$> wrap o b + | Header i b <- bs = inHeaderTags i <$> wrap o b + | BlockQuote b <- bs = mkBlockQuote b + | CodeBlock _ s <- bs = preformatted s + | RawHtml _ <- bs = return empty + | DefinitionList b <- bs = defList b + | BulletList b <- bs = bulletListToOpenDocument o b + | OrderedList a b <- bs = orderedList a b + | Table c a w h r <- bs = table c a w h r + | Null <- bs = return empty + | HorizontalRule <- bs = return $ selfClosingTag "text:p" [ ("text:style-name", "Horizontal_20_Line") ] + | otherwise = return empty + where + defList b = do setInDefinitionList True + r <- vcat <$> mapM (deflistItemToOpenDocument o) b + setInDefinitionList False + return r + preformatted s = vcat <$> mapM (inPreformattedTags . escapeStringForXML) (lines s) + mkBlockQuote b = do increaseIndent + i <- paraStyle "Quotations" [] + inBlockQuote o i (map plainToPara b) + orderedList a b = do (ln,pn) <- newOrderedListStyle (isTightList b) a + inTags True "text:list" [ ("text:style-name", "L" ++ show ln)] + <$> orderedListToOpenDocument o pn b + table c a w h r = do + tn <- length <$> gets stTableStyles + pn <- length <$> gets stParaStyles + let genIds = map chr [65..] + name = "Table" ++ show (tn + 1) + columnIds = zip genIds w + mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name ++ "." ++ [fst n])] + columns = map mkColumn columnIds + paraHStyles = paraTableStyles "Heading" pn a + paraStyles = paraTableStyles "Contents" (pn + length (newPara paraHStyles)) a + newPara = map snd . filter (not . isEmpty . snd) + addTableStyle $ tableStyle tn columnIds + mapM_ addParaStyle . newPara $ paraHStyles ++ paraStyles + captionDoc <- if null c + then return empty + else withParagraphStyle o "Caption" [Para c] + th <- colHeadsToOpenDocument o name (map fst paraHStyles) h + tr <- mapM (tableRowToOpenDocument o name (map fst paraStyles)) r + return $ inTags True "table:table" [ ("table:name" , name) + , ("table:style-name", name) + ] (vcat columns $$ th $$ vcat tr) $$ captionDoc + +colHeadsToOpenDocument :: WriterOptions -> String -> [String] -> [[Block]] -> State WriterState Doc +colHeadsToOpenDocument o tn ns hs = + inTagsIndented "table:table-header-rows" . inTagsIndented "table:table-row" . vcat <$> + mapM (tableItemToOpenDocument o tn) (zip ns hs) + +tableRowToOpenDocument :: WriterOptions -> String -> [String] -> [[Block]] -> State WriterState Doc +tableRowToOpenDocument o tn ns cs = + inTagsIndented "table:table-row" . vcat <$> + mapM (tableItemToOpenDocument o tn) (zip ns cs) + +tableItemToOpenDocument :: WriterOptions -> String -> (String,[Block])-> State WriterState Doc +tableItemToOpenDocument o tn (n,i) = + let a = [ ("table:style-name" , tn ++ ".A1" ) + , ("office:value-type", "string" ) + ] + in inTags True "table:table-cell" a <$> + withParagraphStyle o n (map plainToPara i) + +-- | Take list of inline elements and return wrapped doc. +wrap :: WriterOptions -> [Inline] -> State WriterState Doc +wrap o l = if writerWrapText o + then fsep <$> mapM (inlinesToOpenDocument o) (splitBy Space l) + else inlinesToOpenDocument o l + +-- | Convert a list of inline elements to OpenDocument. +inlinesToOpenDocument :: WriterOptions -> [Inline] -> State WriterState Doc +inlinesToOpenDocument o l = hcat <$> mapM (inlineToOpenDocument o) l + +-- | Convert an inline element to OpenDocument. +inlineToOpenDocument :: WriterOptions -> Inline -> State WriterState Doc +inlineToOpenDocument o ils + | Ellipses <- ils = inTextStyle $ text "…" + | EmDash <- ils = inTextStyle $ text "—" + | EnDash <- ils = inTextStyle $ text "–" + | Apostrophe <- ils = inTextStyle $ text "’" + | Space <- ils = inTextStyle $ char ' ' + | LineBreak <- ils = return $ selfClosingTag "text:line-break" [] + | Str s <- ils = inTextStyle $ handleSpaces $ escapeStringForXML s + | Emph l <- ils = withTextStyle Italic $ inlinesToOpenDocument o l + | Strong l <- ils = withTextStyle Bold $ inlinesToOpenDocument o l + | Strikeout l <- ils = withTextStyle Strike $ inlinesToOpenDocument o l + | Superscript l <- ils = withTextStyle Sup $ inlinesToOpenDocument o l + | Subscript l <- ils = withTextStyle Sub $ inlinesToOpenDocument o l + | SmallCaps l <- ils = withTextStyle SmallC $ inlinesToOpenDocument o l + | Quoted t l <- ils = inQuotes t <$> inlinesToOpenDocument o l + | Code s <- ils = preformatted s + | Math _ s <- ils = inlinesToOpenDocument o (readTeXMath s) + | Cite _ l <- ils = inlinesToOpenDocument o l + | TeX s <- ils = preformatted s + | HtmlInline s <- ils = preformatted s + | Link l (s,t) <- ils = mkLink s t <$> inlinesToOpenDocument o l + | Image _ (s,_) <- ils = return $ mkImg s + | Note l <- ils = mkNote l + | otherwise = return empty + where + preformatted = return . inSpanTags "Teletype" . handleSpaces . escapeStringForXML + mkLink s t = inTags False "text:a" [ ("xlink:type" , "simple") + , ("xlink:href" , s ) + , ("office:name", t ) + ] . inSpanTags "Definition" + mkImg s = inTags False "draw:frame" [] $ + selfClosingTag "draw:image" [ ("xlink:href" , s ) + , ("xlink:type" , "simple") + , (" xlink:show" , "embed" ) + , ("xlink:actuate", "onLoad")] + mkNote l = do + n <- length <$> gets stNotes + let footNote t = inTags False "text:note" + [ ("text:id" , "ftn" ++ show n) + , ("text:note-class", "footnote" )] $ + inTagsSimple "text:note-citation" (text . show $ n + 1) $$ + inTagsSimple "text:note-body" t + nn <- footNote <$> withParagraphStyle o "Footnote" l + addNote nn + return nn + +generateStyles :: [Doc] -> Doc +generateStyles acc = + let scripts = selfClosingTag "office:scripts" [] + fonts = inTagsIndented "office:font-face-decls" + (vcat $ map font ["Lucida Sans Unicode", "Tahoma", "Times New Roman"]) + font fn = selfClosingTag "style:font-face" + [ ("style:name" , "'" ++ fn ++ "'") + , ("svg:font-family", fn )] + in scripts $$ fonts $$ inTagsIndented "office:automatic-styles" (vcat $ reverse acc) + +bulletListStyle :: Int -> State WriterState (Int,(Int,[Doc])) +bulletListStyle l = + let doStyles i = inTags True "text:list-level-style-bullet" + [ ("text:level" , show (i + 1) ) + , ("text:style-name" , "Bullet_20_Symbols") + , ("style:num-suffix", "." ) + , ("text:bullet-char", [bulletList !! i] ) + ] (listLevelStyle (1 + i)) + bulletList = map chr $ cycle [8226,8227,8259] + listElStyle = map doStyles [0..9] + in do pn <- paraListStyle l + return (pn, (l, listElStyle)) + +orderedListLevelStyle :: ListAttributes -> (Int, [Doc]) -> (Int,[Doc]) +orderedListLevelStyle (s,n, d) (l,ls) = + let suffix = case d of + OneParen -> [("style:num-suffix", ")")] + TwoParens -> [("style:num-prefix", "(") + ,("style:num-suffix", ")")] + _ -> [("style:num-suffix", ".")] + format = case n of + UpperAlpha -> "A" + LowerAlpha -> "a" + UpperRoman -> "I" + LowerRoman -> "i" + _ -> "1" + listStyle = inTags True "text:list-level-style-number" + ([ ("text:level" , show $ 1 + length ls ) + , ("text:style-name" , "Numbering_20_Symbols") + , ("style:num-format", format ) + , ("text:start-value", show s ) + ] ++ suffix) (listLevelStyle (1 + length ls)) + in (l, ls ++ [listStyle]) + +listLevelStyle :: Int -> Doc +listLevelStyle i = + let indent = show (0.25 * fromIntegral i :: Double) in + selfClosingTag "style:list-level-properties" + [ ("text:space-before" , indent ++ "in") + , ("text:min-label-width", "0.25in")] + +tableStyle :: Int -> [(Char,Double)] -> Doc +tableStyle num wcs = + let tableId = "Table" ++ show (num + 1) + table = inTags True "style:style" + [("style:name", tableId)] $ + selfClosingTag "style:table-properties" + [ ("style:rel-width", "100%" ) + , ("table:align" , "center")] + colStyle (c,w) = inTags True "style:style" + [ ("style:name" , tableId ++ "." ++ [c]) + , ("style:family", "table-column" )] $ + selfClosingTag "style:table-column-properties" + [("style:column-width", printf "%.2f" (7 * w) ++ "in")] + cellStyle = inTags True "style:style" + [ ("style:name" , tableId ++ ".A1") + , ("style:family", "table-cell" )] $ + selfClosingTag "style:table-cell-properties" + [ ("fo:border", "none")] + columnStyles = map colStyle wcs + in table $$ vcat columnStyles $$ cellStyle + +paraStyle :: String -> [(String,String)] -> State WriterState Int +paraStyle parent attrs = do + pn <- (+) 1 . length <$> gets stParaStyles + i <- (*) 0.5 . fromIntegral <$> gets stIndentPara :: State WriterState Double + b <- gets stInDefinition + t <- gets stTight + let styleAttr = [ ("style:name" , "P" ++ show pn) + , ("style:family" , "paragraph" ) + , ("style:parent-style-name", parent )] + indentVal = flip (++) "in" . show $ if b then (max 0.5 i) else i + tight = if t then [ ("fo:margin-top" , "0in" ) + , ("fo:margin-bottom" , "0in" )] + else [] + indent = when (i /= 0 || b || t) $ + selfClosingTag "style:paragraph-properties" $ + [ ("fo:margin-left" , indentVal) + , ("fo:margin-right" , "0in" ) + , ("fo:text-indent" , "0in" ) + , ("style:auto-text-indent" , "false" )] + ++ tight + addParaStyle $ inTags True "style:style" (styleAttr ++ attrs) indent + return pn + +paraListStyle :: Int -> State WriterState Int +paraListStyle l = paraStyle "Text_20_body" [("style:list-style-name", "L" ++ show l )] + +paraTableStyles :: String -> Int -> [Alignment] -> [(String, Doc)] +paraTableStyles _ _ [] = [] +paraTableStyles t s (a:xs) + | AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs + | AlignCenter <- a = ( pName s, res s "center") : paraTableStyles t (s + 1) xs + | otherwise = ("Table_20_" ++ t, empty ) : paraTableStyles t s xs + where pName sn = "P" ++ show (sn + 1) + res sn x = inTags True "style:style" + [ ("style:name" , pName sn ) + , ("style:family" , "paragraph" ) + , ("style:parent-style-name", "Table_20_" ++ t)] $ + selfClosingTag "style:paragraph-properties" + [ ("fo:text-align", x) + , ("style:justify-single-word", "false")] + +data TextStyle = Italic | Bold | Strike | Sub | Sup | SmallC deriving ( Eq ) + +textStyleAttr :: TextStyle -> [(String,String)] +textStyleAttr s + | Italic <- s = [("fo:font-style" ,"italic" ) + ,("style:font-style-asian" ,"italic" ) + ,("style:font-style-complex" ,"italic" )] + | Bold <- s = [("fo:font-weight" ,"bold" ) + ,("style:font-weight-asian" ,"bold" ) + ,("style:font-weight-complex" ,"bold" )] + | Strike <- s = [("style:text-line-through-style", "solid" )] + | Sub <- s = [("style:text-position" ,"sub 58%" )] + | Sup <- s = [("style:text-position" ,"super 58%" )] + | SmallC <- s = [("fo:font-variant" ,"small-caps")] + | otherwise = [] + +openDocumentNameSpaces :: [(String, String)] +openDocumentNameSpaces = + [ ("xmlns:office" , "urn:oasis:names:tc:opendocument:xmlns:office:1.0" ) + , ("xmlns:style" , "urn:oasis:names:tc:opendocument:xmlns:style:1.0" ) + , ("xmlns:text" , "urn:oasis:names:tc:opendocument:xmlns:text:1.0" ) + , ("xmlns:table" , "urn:oasis:names:tc:opendocument:xmlns:table:1.0" ) + , ("xmlns:draw" , "urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" ) + , ("xmlns:fo" , "urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0") + , ("xmlns:xlink" , "http://www.w3.org/1999/xlink" ) + , ("xmlns:dc" , "http://purl.org/dc/elements/1.1/" ) + , ("xmlns:meta" , "urn:oasis:names:tc:opendocument:xmlns:meta:1.0" ) + , ("xmlns:number" , "urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" ) + , ("xmlns:svg" , "urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" ) + , ("xmlns:chart" , "urn:oasis:names:tc:opendocument:xmlns:chart:1.0" ) + , ("xmlns:dr3d" , "urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" ) + , ("xmlns:math" , "http://www.w3.org/1998/Math/MathML" ) + , ("xmlns:form" , "urn:oasis:names:tc:opendocument:xmlns:form:1.0" ) + , ("xmlns:script" , "urn:oasis:names:tc:opendocument:xmlns:script:1.0" ) + , ("xmlns:ooo" , "http://openoffice.org/2004/office" ) + , ("xmlns:ooow" , "http://openoffice.org/2004/writer" ) + , ("xmlns:oooc" , "http://openoffice.org/2004/calc" ) + , ("xmlns:dom" , "http://www.w3.org/2001/xml-events" ) + , ("xmlns:xforms" , "http://www.w3.org/2002/xforms" ) + , ("xmlns:xsd" , "http://www.w3.org/2001/XMLSchema" ) + , ("xmlns:xsi" , "http://www.w3.org/2001/XMLSchema-instance" ) + , ("office:version", "1.0" ) + ] diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs new file mode 100644 index 000000000..91826cbcd --- /dev/null +++ b/src/Text/Pandoc/Writers/RST.hs @@ -0,0 +1,346 @@ +{- +Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.RST + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to reStructuredText. + +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.Blocks +import Data.List ( isPrefixOf, isSuffixOf, drop, intersperse ) +import Text.PrettyPrint.HughesPJ hiding ( Str ) +import Control.Monad.State +import Control.Applicative ( (<$>) ) + +data WriterState = + WriterState { stNotes :: [[Block]] + , stLinks :: KeyTable + , stImages :: KeyTable + , stIncludes :: [String] + , stOptions :: WriterOptions + } + +-- | Convert Pandoc to RST. +writeRST :: WriterOptions -> Pandoc -> String +writeRST opts document = + let st = WriterState { stNotes = [], stLinks = [], + stImages = [], stIncludes = [], + stOptions = opts } + in render $ evalState (pandocToRST document) st + +-- | Return RST representation of document. +pandocToRST :: Pandoc -> State WriterState Doc +pandocToRST (Pandoc meta blocks) = do + opts <- get >>= (return . stOptions) + let before = writerIncludeBefore opts + let after = writerIncludeAfter opts + before' = if null before then empty else text before + after' = if null after then empty else text after + metaBlock <- metaToRST opts meta + let head' = if (writerStandalone opts) + then metaBlock $+$ text (writerHeader opts) + else empty + body <- blockListToRST blocks + includes <- get >>= (return . concat . stIncludes) + let includes' = if null includes then empty else text includes + notes <- get >>= (notesToRST . reverse . stNotes) + -- note that the notes may contain refs, so we do them first + refs <- get >>= (keyTableToRST . reverse . stLinks) + pics <- get >>= (pictTableToRST . reverse . stImages) + return $ head' $+$ before' $+$ includes' $+$ body $+$ notes $+$ text "" $+$ + refs $+$ pics $+$ after' + +-- | Return RST representation of reference key table. +keyTableToRST :: KeyTable -> State WriterState Doc +keyTableToRST refs = mapM keyToRST refs >>= return . vcat + +-- | Return RST representation of a reference key. +keyToRST :: ([Inline], (String, String)) + -> State WriterState Doc +keyToRST (label, (src, _)) = do + label' <- inlineListToRST label + let label'' = if ':' `elem` (render label') + then char '`' <> label' <> char '`' + else label' + return $ text ".. _" <> label'' <> text ": " <> text src + +-- | Return RST representation of notes. +notesToRST :: [[Block]] -> State WriterState Doc +notesToRST notes = + mapM (\(num, note) -> noteToRST num note) (zip [1..] notes) >>= + return . vcat + +-- | Return RST representation of a note. +noteToRST :: Int -> [Block] -> State WriterState Doc +noteToRST num note = do + contents <- blockListToRST note + let marker = text ".. [" <> text (show num) <> text "]" + return $ marker $$ nest 3 contents + +-- | Return RST representation of picture reference table. +pictTableToRST :: KeyTable -> State WriterState Doc +pictTableToRST refs = mapM pictToRST refs >>= return . vcat + +-- | Return RST representation of a picture substitution reference. +pictToRST :: ([Inline], (String, String)) + -> State WriterState Doc +pictToRST (label, (src, _)) = do + label' <- inlineListToRST label + return $ text ".. " <> char '|' <> label' <> char '|' <> text " image:: " <> + text src + +-- | Take list of inline elements and return wrapped doc. +wrappedRST :: WriterOptions -> [Inline] -> State WriterState Doc +wrappedRST opts inlines = do + lineBreakDoc <- inlineToRST LineBreak + chunks <- mapM (wrapIfNeeded opts inlineListToRST) + (splitBy LineBreak inlines) + return $ vcat $ intersperse lineBreakDoc chunks + +-- | Escape special characters for RST. +escapeString :: String -> String +escapeString = escapeStringUsing (backslashEscapes "`\\|*_") + +-- | Convert bibliographic information into RST header. +metaToRST :: WriterOptions -> Meta -> State WriterState Doc +metaToRST opts (Meta title authors date) = do + title' <- titleToRST title + authors' <- authorsToRST authors + date' <- dateToRST date + let toc = if writerTableOfContents opts + then text "" $+$ text ".. contents::" + else empty + return $ title' $+$ authors' $+$ date' $+$ toc + +titleToRST :: [Inline] -> State WriterState Doc +titleToRST [] = return empty +titleToRST lst = do + contents <- inlineListToRST lst + let titleLength = length $ render contents + let border = text (replicate titleLength '=') + return $ border $+$ contents $+$ border <> text "\n" + +authorsToRST :: [String] -> State WriterState Doc +authorsToRST [] = return empty +authorsToRST (first:rest) = do + rest' <- authorsToRST rest + return $ (text ":Author: " <> text first) $+$ rest' + +dateToRST :: String -> State WriterState Doc +dateToRST [] = return empty +dateToRST str = return $ text ":Date: " <> text (escapeString str) + +-- | Convert Pandoc block element to RST. +blockToRST :: Block -- ^ Block element + -> State WriterState Doc +blockToRST Null = return empty +blockToRST (Plain inlines) = do + opts <- get >>= (return . stOptions) + wrappedRST opts inlines +blockToRST (Para inlines) = do + opts <- get >>= (return . stOptions) + contents <- wrappedRST opts inlines + return $ contents <> text "\n" +blockToRST (RawHtml str) = + let str' = if "\n" `isSuffixOf` str then str ++ "\n" else str ++ "\n\n" in + return $ (text "\n.. raw:: html\n") $$ (nest 3 $ vcat $ map text (lines str')) +blockToRST HorizontalRule = return $ text "--------------\n" +blockToRST (Header level inlines) = do + contents <- inlineListToRST inlines + let headerLength = length $ render contents + let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1) + let border = text $ replicate headerLength headerChar + return $ contents $+$ border <> text "\n" +blockToRST (CodeBlock (_,classes,_) str) = do + opts <- stOptions <$> get + let tabstop = writerTabStop opts + if "haskell" `elem` classes && writerLiterateHaskell opts + then return $ (vcat $ map (text "> " <>) $ map text (lines str)) <> text "\n" + else return $ (text "::\n") $+$ + (nest tabstop $ vcat $ map text (lines str)) <> text "\n" +blockToRST (BlockQuote blocks) = do + tabstop <- get >>= (return . writerTabStop . stOptions) + contents <- blockListToRST blocks + return $ (nest tabstop contents) <> text "\n" +blockToRST (Table caption _ widths headers rows) = do + caption' <- inlineListToRST caption + let caption'' = if null caption + then empty + else text "" $+$ (text "Table: " <> caption') + headers' <- mapM blockListToRST headers + let widthsInChars = map (floor . (78 *)) widths + let hpipeBlocks blocks = hcatBlocks [beg, middle, end] + where height = maximum (map heightOfBlock blocks) + sep' = TextBlock 3 height (replicate height " | ") + beg = TextBlock 2 height (replicate height "| ") + end = TextBlock 2 height (replicate height " |") + middle = hcatBlocks $ intersperse sep' blocks + let makeRow = hpipeBlocks . zipWith docToBlock widthsInChars + let head' = makeRow headers' + 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) $ + map (\l -> text $ replicate l ch) widthsInChars) <> + char ch <> char '+' + let body = vcat $ intersperse (border '-') $ map blockToDoc rows' + return $ border '-' $+$ blockToDoc head' $+$ border '=' $+$ body $+$ + border '-' $$ caption'' $$ text "" +blockToRST (BulletList items) = do + contents <- mapM bulletListItemToRST items + -- ensure that sublists have preceding blank line + return $ text "" $+$ vcat contents <> text "\n" +blockToRST (OrderedList (start, style', delim) items) = do + let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim + then take (length items) $ repeat "#." + else take (length items) $ orderedListMarkers + (start, style', delim) + let maxMarkerLength = maximum $ map length markers + let markers' = map (\m -> let s = maxMarkerLength - length m + in m ++ replicate s ' ') markers + contents <- mapM (\(item, num) -> orderedListItemToRST item num) $ + zip markers' items + -- ensure that sublists have preceding blank line + return $ text "" $+$ vcat contents <> text "\n" +blockToRST (DefinitionList items) = do + contents <- mapM definitionListItemToRST items + return $ (vcat contents) <> text "\n" + +-- | Convert bullet list item (list of blocks) to RST. +bulletListItemToRST :: [Block] -> State WriterState Doc +bulletListItemToRST items = do + contents <- blockListToRST items + return $ (text "- ") <> contents + +-- | Convert ordered list item (a list of blocks) to RST. +orderedListItemToRST :: String -- ^ marker for list item + -> [Block] -- ^ list item (list of blocks) + -> State WriterState Doc +orderedListItemToRST marker items = do + contents <- blockListToRST items + return $ (text marker <> char ' ') <> contents + +-- | Convert defintion list item (label, list of blocks) to RST. +definitionListItemToRST :: ([Inline], [Block]) -> State WriterState Doc +definitionListItemToRST (label, items) = do + label' <- inlineListToRST label + contents <- blockListToRST items + tabstop <- get >>= (return . writerTabStop . stOptions) + return $ label' $+$ nest tabstop contents + +-- | Convert list of Pandoc block elements to RST. +blockListToRST :: [Block] -- ^ List of block elements + -> State WriterState Doc +blockListToRST blocks = mapM blockToRST blocks >>= return . vcat + +-- | Convert list of Pandoc inline elements to RST. +inlineListToRST :: [Inline] -> State WriterState Doc +inlineListToRST lst = mapM inlineToRST lst >>= return . hcat + +-- | Convert Pandoc inline element to RST. +inlineToRST :: Inline -> State WriterState Doc +inlineToRST (Emph lst) = do + contents <- inlineListToRST lst + return $ char '*' <> contents <> char '*' +inlineToRST (Strong lst) = do + contents <- inlineListToRST lst + return $ text "**" <> contents <> text "**" +inlineToRST (Strikeout lst) = do + contents <- inlineListToRST lst + return $ text "[STRIKEOUT:" <> contents <> char ']' +inlineToRST (Superscript lst) = do + contents <- inlineListToRST lst + return $ text "\\ :sup:`" <> contents <> text "`\\ " +inlineToRST (Subscript lst) = do + contents <- inlineListToRST lst + return $ text "\\ :sub:`" <> contents <> text "`\\ " +inlineToRST (SmallCaps lst) = inlineListToRST lst +inlineToRST (Quoted SingleQuote lst) = do + contents <- inlineListToRST lst + return $ char '\'' <> contents <> char '\'' +inlineToRST (Quoted DoubleQuote lst) = do + contents <- inlineListToRST lst + return $ char '"' <> contents <> char '"' +inlineToRST (Cite _ lst) = + inlineListToRST lst +inlineToRST EmDash = return $ text "--" +inlineToRST EnDash = return $ char '-' +inlineToRST Apostrophe = return $ char '\'' +inlineToRST Ellipses = return $ text "..." +inlineToRST (Code str) = return $ text $ "``" ++ str ++ "``" +inlineToRST (Str str) = return $ text $ escapeString str +inlineToRST (Math t str) = do + includes <- get >>= (return . stIncludes) + let rawMathRole = ".. role:: math(raw)\n" ++ + " :format: html latex\n" + if not (rawMathRole `elem` includes) + then modify $ \st -> st { stIncludes = rawMathRole : includes } + else return () + return $ if t == InlineMath + then text $ ":math:`$" ++ str ++ "$`" + else text $ ":math:`$$" ++ str ++ "$$`" +inlineToRST (TeX _) = return empty +inlineToRST (HtmlInline _) = return empty +inlineToRST (LineBreak) = do + return $ empty -- there's no line break in RST +inlineToRST Space = return $ char ' ' +inlineToRST (Link [Code str] (src, _)) | src == str || + src == "mailto:" ++ str = do + let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src + return $ text srcSuffix +inlineToRST (Link txt (src, tit)) = do + useReferenceLinks <- get >>= (return . writerReferenceLinks . stOptions) + linktext <- inlineListToRST $ normalizeSpaces txt + if useReferenceLinks + then do refs <- get >>= (return . stLinks) + let refs' = if (txt, (src, tit)) `elem` refs + then refs + else (txt, (src, tit)):refs + modify $ \st -> st { stLinks = refs' } + return $ char '`' <> linktext <> text "`_" + else return $ char '`' <> linktext <> text " <" <> text src <> text ">`_" +inlineToRST (Image alternate (source, tit)) = do + pics <- get >>= (return . stImages) + let labelsUsed = map fst pics + let txt = if null alternate || alternate == [Str ""] || + alternate `elem` labelsUsed + then [Str $ "image" ++ show (length pics)] + else alternate + let pics' = if (txt, (source, tit)) `elem` pics + then pics + else (txt, (source, tit)):pics + modify $ \st -> st { stImages = pics' } + label <- inlineListToRST txt + return $ char '|' <> label <> char '|' +inlineToRST (Note contents) = do + -- add to notes in state + notes <- get >>= (return . stNotes) + modify $ \st -> st { stNotes = contents:notes } + let ref = show $ (length notes) + 1 + return $ text " [" <> text ref <> text "]_" diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs new file mode 100644 index 000000000..fc6cd1bf0 --- /dev/null +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -0,0 +1,291 @@ +{- +Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.RTF + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to RTF (rich text format). +-} +module Text.Pandoc.Writers.RTF ( writeRTF ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Pandoc.Readers.TeXMath +import Data.List ( isSuffixOf, intercalate ) +import Data.Char ( ord, isDigit ) + +-- | Convert Pandoc to a string in rich text format. +writeRTF :: WriterOptions -> Pandoc -> String +writeRTF options (Pandoc meta blocks) = + let head' = if writerStandalone options + then rtfHeader (writerHeader options) meta + else "" + toc = if writerTableOfContents options + then tableOfContents $ filter isHeaderBlock blocks + else "" + foot = if writerStandalone options then "\n}\n" else "" + body = writerIncludeBefore options ++ + concatMap (blockToRTF 0 AlignDefault) blocks ++ + writerIncludeAfter options + in head' ++ toc ++ body ++ foot + +-- | Construct table of contents from list of header blocks. +tableOfContents :: [Block] -> String +tableOfContents headers = + let contentsTree = hierarchicalize headers + in concatMap (blockToRTF 0 AlignDefault) $ + [Header 1 [Str "Contents"], + BulletList (map elementToListItem contentsTree)] + +elementToListItem :: Element -> [Block] +elementToListItem (Blk _) = [] +elementToListItem (Sec sectext subsecs) = [Plain sectext] ++ + if null subsecs + then [] + else [BulletList (map elementToListItem subsecs)] + +-- | Convert unicode characters (> 127) into rich text format representation. +handleUnicode :: String -> String +handleUnicode [] = [] +handleUnicode (c:cs) = + if ord c > 127 + then '\\':'u':(show (ord c)) ++ "?" ++ handleUnicode cs + else c:(handleUnicode cs) + +-- | Escape special characters. +escapeSpecial :: String -> String +escapeSpecial = escapeStringUsing (('\t',"\\tab "):(backslashEscapes "{\\}")) + +-- | Escape strings as needed for rich text format. +stringToRTF :: String -> String +stringToRTF = handleUnicode . escapeSpecial + +-- | Escape things as needed for code block in RTF. +codeStringToRTF :: String -> String +codeStringToRTF str = intercalate "\\line\n" $ lines (stringToRTF str) + +-- | Make a paragraph with first-line indent, block indent, and space after. +rtfParSpaced :: Int -- ^ space after (in twips) + -> Int -- ^ block indent (in twips) + -> Int -- ^ first line indent (relative to block) (in twips) + -> Alignment -- ^ alignment + -> String -- ^ string with 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) ++ + " \\fi" ++ (show firstLineIndent) ++ " " ++ content ++ "\\par}\n" + +-- | 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 + +-- | 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 + +-- number of twips to indent +indentIncrement :: Int +indentIncrement = 720 + +listIncrement :: Int +listIncrement = 360 + +-- | Returns appropriate bullet list marker for indent level. +bulletMarker :: Int -> String +bulletMarker indent = case indent `mod` 720 of + 0 -> "\\bullet " + _ -> "\\endash " + +-- | Returns appropriate (list of) ordered list markers for indent level. +orderedMarkers :: Int -> ListAttributes -> [String] +orderedMarkers indent (start, style, delim) = + if style == DefaultStyle && delim == DefaultDelim + then case indent `mod` 720 of + 0 -> orderedListMarkers (start, Decimal, Period) + _ -> orderedListMarkers (start, LowerAlpha, Period) + else orderedListMarkers (start, style, delim) + +-- | Returns RTF header. +rtfHeader :: String -- ^ header text + -> Meta -- ^ bibliographic information + -> String +rtfHeader headerText (Meta title authors date) = + let titletext = if null title + then "" + else rtfPar 0 0 AlignCenter $ + "\\b \\fs36 " ++ inlineListToRTF title + authorstext = if null authors + then "" + else rtfPar 0 0 AlignCenter (" " ++ (intercalate "\\" $ + map stringToRTF authors)) + datetext = if date == "" + then "" + else rtfPar 0 0 AlignCenter (" " ++ stringToRTF date) in + let spacer = if null (titletext ++ authorstext ++ datetext) + then "" + else rtfPar 0 0 AlignDefault "" in + headerText ++ titletext ++ authorstext ++ datetext ++ spacer + +-- | Convert Pandoc block element to RTF. +blockToRTF :: Int -- ^ indent level + -> Alignment -- ^ alignment + -> Block -- ^ block to convert + -> String +blockToRTF _ _ Null = "" +blockToRTF indent alignment (Plain lst) = + rtfCompact indent 0 alignment $ inlineListToRTF 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 _ (CodeBlock _ str) = + rtfPar indent 0 AlignLeft ("\\f1 " ++ (codeStringToRTF str)) +blockToRTF _ _ (RawHtml _) = "" +blockToRTF indent alignment (BulletList lst) = spaceAtEnd $ + concatMap (listItemToRTF alignment indent (bulletMarker indent)) lst +blockToRTF indent alignment (OrderedList attribs lst) = spaceAtEnd $ concat $ + zipWith (listItemToRTF alignment indent) (orderedMarkers indent attribs) lst +blockToRTF indent alignment (DefinitionList lst) = spaceAtEnd $ + concatMap (definitionListItemToRTF alignment indent) lst +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) = + tableRowToRTF True indent aligns sizes headers ++ + concatMap (tableRowToRTF False indent aligns sizes) rows ++ + rtfPar indent 0 alignment (inlineListToRTF caption) + +tableRowToRTF :: Bool -> Int -> [Alignment] -> [Double] -> [[Block]] -> String +tableRowToRTF header indent aligns sizes cols = + let columns = concat $ zipWith (tableItemToRTF indent) aligns cols + totalTwips = 6 * 1440 -- 6 inches + rightEdges = tail $ scanl (\sofar new -> sofar + floor (new * totalTwips)) + (0 :: Integer) sizes + cellDefs = map (\edge -> (if header + then "\\clbrdrb\\brdrs" + else "") ++ "\\cellx" ++ show edge) + rightEdges + start = "{\n\\trowd \\trgaph120\n" ++ concat cellDefs ++ "\n" ++ + "\\trkeep\\intbl\n{\n" + end = "}\n\\intbl\\row}\n" + in start ++ columns ++ end + +tableItemToRTF :: Int -> Alignment -> [Block] -> String +tableItemToRTF indent alignment item = + let contents = concatMap (blockToRTF indent alignment) item + in "{\\intbl " ++ contents ++ "\\cell}\n" + +-- | Ensure that there's the same amount of space after compact +-- lists as after regular lists. +spaceAtEnd :: String -> String +spaceAtEnd str = + if isSuffixOf "\\par}\n" str + then (take ((length str) - 6) str) ++ "\\sa180\\par}\n" + else str + +-- | Convert list item (list of blocks) to RTF. +listItemToRTF :: Alignment -- ^ alignment + -> Int -- ^ indent level + -> 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 = + let (first:rest) = map (blockToRTF (indent + listIncrement) alignment) list + listMarker = "\\fi" ++ show (0 - listIncrement) ++ " " ++ marker ++ "\\tx" ++ + show listIncrement ++ "\\tab" + insertListMarker ('\\':'f':'i':'-':d:xs) | isDigit d = + listMarker ++ dropWhile isDigit xs + insertListMarker ('\\':'f':'i':d:xs) | isDigit d = + listMarker ++ dropWhile isDigit xs + insertListMarker (x:xs) = + x : insertListMarker xs + insertListMarker [] = [] + -- insert the list marker into the (processed) first block + in insertListMarker first ++ concat rest + +-- | Convert definition list item (label, list of blocks) to RTF. +definitionListItemToRTF :: Alignment -- ^ alignment + -> Int -- ^ indent level + -> ([Inline],[Block]) -- ^ list item (list of blocks) + -> [Char] +definitionListItemToRTF alignment indent (label, items) = + let labelText = blockToRTF indent alignment (Plain label) + itemsText = concatMap (blockToRTF (indent + listIncrement) alignment) items + in labelText ++ itemsText + +-- | Convert list of inline items to RTF. +inlineListToRTF :: [Inline] -- ^ list of inlines to convert + -> String +inlineListToRTF lst = concatMap inlineToRTF lst + +-- | Convert inline item to RTF. +inlineToRTF :: Inline -- ^ inline to convert + -> String +inlineToRTF (Emph lst) = "{\\i " ++ (inlineListToRTF lst) ++ "}" +inlineToRTF (Strong lst) = "{\\b " ++ (inlineListToRTF lst) ++ "}" +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) = + "\\u8216'" ++ (inlineListToRTF lst) ++ "\\u8217'" +inlineToRTF (Quoted DoubleQuote lst) = + "\\u8220\"" ++ (inlineListToRTF lst) ++ "\\u8221\"" +inlineToRTF Apostrophe = "\\u8217'" +inlineToRTF Ellipses = "\\u8230?" +inlineToRTF EmDash = "\\u8212-" +inlineToRTF EnDash = "\\u8211-" +inlineToRTF (Code str) = "{\\f1 " ++ (codeStringToRTF str) ++ "}" +inlineToRTF (Str str) = stringToRTF str +inlineToRTF (Math _ str) = inlineListToRTF $ readTeXMath str +inlineToRTF (Cite _ lst) = inlineListToRTF lst +inlineToRTF (TeX _) = "" +inlineToRTF (HtmlInline _) = "" +inlineToRTF (LineBreak) = "\\line " +inlineToRTF Space = " " +inlineToRTF (Link text (src, _)) = + "{\\field{\\*\\fldinst{HYPERLINK \"" ++ (codeStringToRTF src) ++ + "\"}}{\\fldrslt{\\ul\n" ++ (inlineListToRTF text) ++ "\n}}}\n" +inlineToRTF (Image _ (source, _)) = + "{\\cf1 [image: " ++ source ++ "]\\cf0}" +inlineToRTF (Note contents) = + "{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " ++ + (concatMap (blockToRTF 0 AlignDefault) contents) ++ "}" diff --git a/src/Text/Pandoc/Writers/S5.hs b/src/Text/Pandoc/Writers/S5.hs new file mode 100644 index 000000000..6f528503a --- /dev/null +++ b/src/Text/Pandoc/Writers/S5.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP, TemplateHaskell #-} +{- +Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu> + +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 +-} + +{- | + Module : Text.Pandoc.Writers.S5 + Copyright : Copyright (C) 2006-7 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Definitions for creation of S5 powerpoint-like HTML. +(See <http://meyerweb.com/eric/tools/s5/>.) +-} +module Text.Pandoc.Writers.S5 ( + -- * Strings + s5Meta, + s5Javascript, + s5CSS, + s5Links, + -- * Functions + writeS5, + writeS5String, + insertS5Structure + ) where +import Text.Pandoc.Shared ( WriterOptions ) +import Text.Pandoc.TH ( contentsOf ) +import Text.Pandoc.Writers.HTML ( writeHtml, writeHtmlString ) +import Text.Pandoc.Definition +import Text.XHtml.Strict +import System.FilePath ( (</>) ) +import Data.List ( intercalate ) + +s5Meta :: String +s5Meta = "<!-- configuration parameters -->\n<meta name=\"defaultView\" content=\"slideshow\" />\n<meta name=\"controlVis\" content=\"hidden\" />\n" + +s5Javascript :: String +#ifndef __HADDOCK__ +s5Javascript = "<script type=\"text/javascript\">\n" ++ + $(contentsOf $ "data" </> "ui" </> "default" </> "slides.js.comment") ++ + $(contentsOf $ "data" </> "ui" </> "default" </> "slides.js.packed") ++ "</script>\n" +#endif + +s5CoreCSS :: String +#ifndef __HADDOCK__ +s5CoreCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "s5-core.css") +#endif + +s5FramingCSS :: String +#ifndef __HADDOCK__ +s5FramingCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "framing.css") +#endif + +s5PrettyCSS :: String +#ifndef __HADDOCK__ +s5PrettyCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "pretty.css") +#endif + +s5OperaCSS :: String +#ifndef __HADDOCK__ +s5OperaCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "opera.css") +#endif + +s5OutlineCSS :: String +#ifndef __HADDOCK__ +s5OutlineCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "outline.css") +#endif + +s5PrintCSS :: String +#ifndef __HADDOCK__ +s5PrintCSS = $(contentsOf $ "data" </> "ui" </> "default" </> "print.css") +#endif + +s5CSS :: String +s5CSS = "<style type=\"text/css\" media=\"projection\" id=\"slideProj\">\n" ++ s5CoreCSS ++ "\n" ++ s5FramingCSS ++ "\n" ++ s5PrettyCSS ++ "\n</style>\n<style type=\"text/css\" media=\"projection\" id=\"operaFix\">\n" ++ s5OperaCSS ++ "\n</style>\n<style type=\"text/css\" media=\"screen\" id=\"outlineStyle\">\n" ++ s5OutlineCSS ++ "\n</style>\n<style type=\"text/css\" media=\"print\" id=\"slidePrint\">\n" ++ s5PrintCSS ++ "\n</style>\n" + +s5Links :: String +s5Links = "<!-- style sheet links -->\n<link rel=\"stylesheet\" href=\"ui/default/slides.css\" type=\"text/css\" media=\"projection\" id=\"slideProj\" />\n<link rel=\"stylesheet\" href=\"ui/default/outline.css\" type=\"text/css\" media=\"screen\" id=\"outlineStyle\" />\n<link rel=\"stylesheet\" href=\"ui/default/print.css\" type=\"text/css\" media=\"print\" id=\"slidePrint\" />\n<link rel=\"stylesheet\" href=\"ui/default/opera.css\" type=\"text/css\" media=\"projection\" id=\"operaFix\" />\n<!-- S5 JS -->\n<script src=\"ui/default/slides.js\" type=\"text/javascript\"></script>\n" + +-- | Converts Pandoc document to an S5 HTML presentation (Html structure). +writeS5 :: WriterOptions -> Pandoc -> Html +writeS5 options = (writeHtml options) . insertS5Structure + +-- | Converts Pandoc document to an S5 HTML presentation (string). +writeS5String :: WriterOptions -> Pandoc -> String +writeS5String options = (writeHtmlString options) . insertS5Structure + +-- | Inserts HTML needed for an S5 presentation (e.g. around slides). +layoutDiv :: [Inline] -- ^ Title of document (for header or footer) + -> String -- ^ Date of document (for header or footer) + -> [Block] -- ^ List of block elements returned +layoutDiv title' date = [(RawHtml "<div class=\"layout\">\n<div id=\"controls\"></div>\n<div id=\"currentSlide\"></div>\n<div id=\"header\"></div>\n<div id=\"footer\">\n"), (Header 1 [Str date]), (Header 2 title'), (RawHtml "</div>\n</div>\n")] + +presentationStart :: Block +presentationStart = RawHtml "<div class=\"presentation\">\n\n" + +presentationEnd :: Block +presentationEnd = RawHtml "</div>\n" + +slideStart :: Block +slideStart = RawHtml "<div class=\"slide\">\n" + +slideEnd :: Block +slideEnd = RawHtml "</div>\n" + +-- | Returns 'True' if block is a Header 1. +isH1 :: Block -> Bool +isH1 (Header 1 _) = True +isH1 _ = False + +-- | Insert HTML around sections to make individual slides. +insertSlides :: Bool -> [Block] -> [Block] +insertSlides beginning blocks = + let (beforeHead, rest) = break isH1 blocks in + if (null rest) then + if beginning then + beforeHead + else + beforeHead ++ [slideEnd] + else + if beginning then + beforeHead ++ + slideStart:(head rest):(insertSlides False (tail rest)) + else + beforeHead ++ + slideEnd:slideStart:(head rest):(insertSlides False (tail rest)) + +-- | Insert blocks into 'Pandoc' for slide structure. +insertS5Structure :: Pandoc -> Pandoc +insertS5Structure (Pandoc meta' []) = Pandoc meta' [] +insertS5Structure (Pandoc (Meta title' authors date) blocks) = + let slides = insertSlides True blocks + firstSlide = if not (null title') + then [slideStart, (Header 1 title'), + (Header 3 [Str (intercalate ", " authors)]), + (Header 4 [Str date]), slideEnd] + else [] + newBlocks = (layoutDiv title' date) ++ presentationStart:firstSlide ++ + slides ++ [presentationEnd] + in Pandoc (Meta title' authors date) newBlocks diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs new file mode 100644 index 000000000..305a1a8d0 --- /dev/null +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -0,0 +1,474 @@ +{- +Copyright (C) 2008 John MacFarlane and Peter Wang + +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 +-} + +{- | + Module : Text.Pandoc.Writers.Texinfo + Copyright : Copyright (C) 2008 John MacFarlane and Peter Wang + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane <jgm@berkeley.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' format into Texinfo. +-} +module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Pandoc.Readers.TeXMath +import Text.Printf ( printf ) +import Data.List ( isSuffixOf ) +import Data.Char ( chr, ord ) +import qualified Data.Set as S +import Control.Monad.State +import Text.PrettyPrint.HughesPJ hiding ( Str ) + +data WriterState = + WriterState { stIncludes :: S.Set String -- strings to include in header + } + +{- TODO: + - internal cross references a la HTML + - generated .texi files don't work when run through texi2dvi + -} + +-- | Add line to header. +addToHeader :: String -> State WriterState () +addToHeader str = do + st <- get + let includes = stIncludes st + put st {stIncludes = S.insert str includes} + +-- | Convert Pandoc to Texinfo. +writeTexinfo :: WriterOptions -> Pandoc -> String +writeTexinfo options document = + render $ evalState (pandocToTexinfo options $ wrapTop document) $ + WriterState { stIncludes = S.empty } + +-- | Add a "Top" node around the document, needed by Texinfo. +wrapTop :: Pandoc -> Pandoc +wrapTop (Pandoc (Meta title authors date) blocks) = + Pandoc (Meta title authors date) (Header 0 title : blocks) + +pandocToTexinfo :: WriterOptions -> Pandoc -> State WriterState Doc +pandocToTexinfo options (Pandoc meta blocks) = do + main <- blockListToTexinfo blocks + head' <- if writerStandalone options + then texinfoHeader options meta + else return empty + let before = if null (writerIncludeBefore options) + then empty + else text (writerIncludeBefore options) + let after = if null (writerIncludeAfter options) + then empty + else text (writerIncludeAfter options) + let body = before $$ main $$ after + -- XXX toc untested + let toc = if writerTableOfContents options + then text "@contents" + else empty + let foot = if writerStandalone options + then text "@bye" + else empty + return $ head' $$ toc $$ body $$ foot + +-- | Insert bibliographic information into Texinfo header. +texinfoHeader :: WriterOptions -- ^ Options, including Texinfo header + -> Meta -- ^ Meta with bibliographic information + -> State WriterState Doc +texinfoHeader options (Meta title authors date) = do + titletext <- if null title + then return empty + else do + t <- inlineListToTexinfo title + return $ text "@title " <> t + headerIncludes <- get >>= return . S.toList . stIncludes + let extras = text $ unlines headerIncludes + let authorstext = map makeAuthor authors + let datetext = if date == "" + then empty + else text $ stringToTexinfo date + + let baseHeader = text $ writerHeader options + let header = baseHeader $$ extras + return $ text "\\input texinfo" $$ + header $$ + text "@ifnottex" $$ + text "@paragraphindent 0" $$ + text "@end ifnottex" $$ + text "@titlepage" $$ + titletext $$ vcat authorstext $$ + datetext $$ + text "@end titlepage" + +makeAuthor :: String -> Doc +makeAuthor author = text $ "@author " ++ (stringToTexinfo author) + +-- | Escape things as needed for Texinfo. +stringToTexinfo :: String -> String +stringToTexinfo = escapeStringUsing texinfoEscapes + where texinfoEscapes = [ ('{', "@{") + , ('}', "@}") + , ('@', "@@") + , (',', "@comma{}") -- only needed in argument lists + , ('\160', "@ ") + ] + +-- | Puts contents into Texinfo command. +inCmd :: String -> Doc -> Doc +inCmd cmd contents = char '@' <> text cmd <> braces contents + +-- | Convert Pandoc block element to Texinfo. +blockToTexinfo :: Block -- ^ Block to convert + -> State WriterState Doc + +blockToTexinfo Null = return empty + +blockToTexinfo (Plain lst) = + inlineListToTexinfo lst + +blockToTexinfo (Para lst) = + inlineListToTexinfo lst -- this is handled differently from Plain in blockListToTexinfo + +blockToTexinfo (BlockQuote lst) = do + contents <- blockListToTexinfo lst + return $ text "@quotation" $$ + contents $$ + text "@end quotation" + +blockToTexinfo (CodeBlock _ str) = do + return $ text "@verbatim" $$ + vcat (map text (lines str)) $$ + text "@end verbatim\n" + +blockToTexinfo (RawHtml _) = return empty + +blockToTexinfo (BulletList lst) = do + items <- mapM listItemToTexinfo lst + return $ text "@itemize" $$ + vcat items $$ + text "@end itemize\n" + +blockToTexinfo (OrderedList (start, numstyle, _) lst) = do + items <- mapM listItemToTexinfo lst + return $ text "@enumerate " <> exemplar $$ + vcat items $$ + text "@end enumerate\n" + where + exemplar = case numstyle of + DefaultStyle -> decimal + Decimal -> decimal + UpperRoman -> decimal -- Roman numerals not supported + LowerRoman -> decimal + UpperAlpha -> upperAlpha + LowerAlpha -> lowerAlpha + decimal = if start == 1 + then empty + else text (show start) + upperAlpha = text [chr $ ord 'A' + start - 1] + lowerAlpha = text [chr $ ord 'a' + start - 1] + +blockToTexinfo (DefinitionList lst) = do + items <- mapM defListItemToTexinfo lst + return $ text "@table @asis" $$ + vcat items $$ + text "@end table\n" + +blockToTexinfo HorizontalRule = + -- XXX can't get the equivalent from LaTeX.hs to work + return $ text "@iftex" $$ + text "@bigskip@hrule@bigskip" $$ + text "@end iftex" $$ + text "@ifnottex" $$ + text (take 72 $ repeat '-') $$ + text "@end ifnottex" + +blockToTexinfo (Header 0 lst) = do + txt <- if null lst + then return $ text "Top" + else inlineListToTexinfo lst + return $ text "@node Top" $$ + text "@top " <> txt <> char '\n' + +blockToTexinfo (Header level lst) = do + node <- inlineListForNode lst + txt <- inlineListToTexinfo lst + return $ if (level > 0) && (level <= 4) + then text "\n@node " <> node <> char '\n' <> + text (seccmd level) <> txt + else txt + where + seccmd 1 = "@chapter " + seccmd 2 = "@section " + seccmd 3 = "@subsection " + seccmd 4 = "@subsubsection " + seccmd _ = error "illegal seccmd level" + +blockToTexinfo (Table caption aligns widths heads rows) = do + headers <- tableHeadToTexinfo aligns heads + captionText <- inlineListToTexinfo caption + rowsText <- mapM (tableRowToTexinfo aligns) rows + let colWidths = map (printf "%.2f ") widths + let colDescriptors = concat colWidths + let tableBody = text ("@multitable @columnfractions " ++ colDescriptors) $$ + headers $$ + vcat rowsText $$ + text "@end multitable" + return $ if isEmpty captionText + then tableBody <> char '\n' + else text "@float" $$ + tableBody $$ + inCmd "caption" captionText $$ + text "@end float" + +tableHeadToTexinfo :: [Alignment] + -> [[Block]] + -> State WriterState Doc +tableHeadToTexinfo = tableAnyRowToTexinfo "@headitem " + +tableRowToTexinfo :: [Alignment] + -> [[Block]] + -> State WriterState Doc +tableRowToTexinfo = tableAnyRowToTexinfo "@item " + +tableAnyRowToTexinfo :: String + -> [Alignment] + -> [[Block]] + -> State WriterState Doc +tableAnyRowToTexinfo itemtype aligns cols = + zipWithM alignedBlock aligns cols >>= + return . (text itemtype $$) . foldl (\row item -> row $$ + (if isEmpty row then empty else text " @tab ") <> item) empty + +alignedBlock :: Alignment + -> [Block] + -> State WriterState Doc +-- XXX @flushleft and @flushright text won't get word wrapped. Since word +-- wrapping is more important than alignment, we ignore the alignment. +alignedBlock _ = blockListToTexinfo +{- +alignedBlock AlignLeft col = do + b <- blockListToTexinfo col + return $ text "@flushleft" $$ b $$ text "@end flushleft" +alignedBlock AlignRight col = do + b <- blockListToTexinfo col + return $ text "@flushright" $$ b $$ text "@end flushright" +alignedBlock _ col = blockListToTexinfo col +-} + +-- | Convert Pandoc block elements to Texinfo. +blockListToTexinfo :: [Block] + -> State WriterState Doc +blockListToTexinfo [] = return $ empty +blockListToTexinfo (x:xs) = do + x' <- blockToTexinfo x + case x of + Header level _ -> do + -- We need need to insert a menu for this node. + let (before, after) = break isHeader xs + before' <- blockListToTexinfo before + let menu = if level < 4 + then collectNodes (level + 1) after + else [] + lines' <- mapM makeMenuLine menu + let menu' = if null lines' + then empty + else text "@menu" $$ + vcat lines' $$ + text "@end menu" + after' <- blockListToTexinfo after + return $ x' $$ before' $$ menu' $$ after' + Para _ -> do + xs' <- blockListToTexinfo xs + case xs of + ((CodeBlock _ _):_) -> return $ x' $$ xs' + _ -> return $ x' $$ text "" $$ xs' + _ -> do + xs' <- blockListToTexinfo xs + return $ x' $$ xs' + +isHeader :: Block -> Bool +isHeader (Header _ _) = True +isHeader _ = False + +collectNodes :: Int -> [Block] -> [Block] +collectNodes _ [] = [] +collectNodes level (x:xs) = + case x of + (Header hl _) -> + if hl < level + then [] + else if hl == level + then x : collectNodes level xs + else collectNodes level xs + _ -> + collectNodes level xs + +makeMenuLine :: Block + -> State WriterState Doc +makeMenuLine (Header _ lst) = do + txt <- inlineListForNode lst + return $ text "* " <> txt <> text "::" +makeMenuLine _ = error "makeMenuLine called with non-Header block" + +listItemToTexinfo :: [Block] + -> State WriterState Doc +listItemToTexinfo lst = blockListToTexinfo lst >>= + return . (text "@item" $$) + +defListItemToTexinfo :: ([Inline], [Block]) + -> State WriterState Doc +defListItemToTexinfo (term, def) = do + term' <- inlineListToTexinfo term + def' <- blockListToTexinfo def + return $ text "@item " <> term' <> text "\n" $$ def' + +-- | Convert list of inline elements to Texinfo. +inlineListToTexinfo :: [Inline] -- ^ Inlines to convert + -> State WriterState Doc +inlineListToTexinfo lst = mapM inlineToTexinfo lst >>= return . hcat + +-- | Convert list of inline elements to Texinfo acceptable for a node name. +inlineListForNode :: [Inline] -- ^ Inlines to convert + -> State WriterState Doc +inlineListForNode lst = mapM inlineForNode lst >>= return . hcat + +inlineForNode :: Inline -> State WriterState Doc +inlineForNode (Str str) = return $ text $ filter (not.disallowedInNode) str +inlineForNode (Emph lst) = inlineListForNode lst +inlineForNode (Strong lst) = inlineListForNode lst +inlineForNode (Strikeout lst) = inlineListForNode lst +inlineForNode (Superscript lst) = inlineListForNode lst +inlineForNode (Subscript lst) = inlineListForNode lst +inlineForNode (SmallCaps lst) = inlineListForNode lst +inlineForNode (Quoted _ lst) = inlineListForNode lst +inlineForNode (Cite _ lst) = inlineListForNode lst +inlineForNode (Code str) = inlineForNode (Str str) +inlineForNode Space = return $ char ' ' +inlineForNode EmDash = return $ text "---" +inlineForNode EnDash = return $ text "--" +inlineForNode Apostrophe = return $ char '\'' +inlineForNode Ellipses = return $ text "..." +inlineForNode LineBreak = return empty +inlineForNode (Math _ str) = inlineListForNode $ readTeXMath str +inlineForNode (TeX _) = return empty +inlineForNode (HtmlInline _) = return empty +inlineForNode (Link lst _) = inlineListForNode lst +inlineForNode (Image lst _) = inlineListForNode lst +inlineForNode (Note _) = return empty + +-- periods, commas, colons, and parentheses are disallowed in node names +disallowedInNode :: Char -> Bool +disallowedInNode c = c `elem` ".,:()" + +-- | Convert inline element to Texinfo +inlineToTexinfo :: Inline -- ^ Inline to convert + -> State WriterState Doc + +inlineToTexinfo (Emph lst) = + inlineListToTexinfo lst >>= return . inCmd "emph" + +inlineToTexinfo (Strong lst) = + inlineListToTexinfo lst >>= return . inCmd "strong" + +inlineToTexinfo (Strikeout lst) = do + addToHeader $ "@macro textstrikeout{text}\n" ++ + "~~\\text\\~~\n" ++ + "@end macro\n" + contents <- inlineListToTexinfo lst + return $ text "@textstrikeout{" <> contents <> text "}" + +inlineToTexinfo (Superscript lst) = do + addToHeader $ "@macro textsuperscript{text}\n" ++ + "@iftex\n" ++ + "@textsuperscript{\\text\\}\n" ++ + "@end iftex\n" ++ + "@ifnottex\n" ++ + "^@{\\text\\@}\n" ++ + "@end ifnottex\n" ++ + "@end macro\n" + contents <- inlineListToTexinfo lst + return $ text "@textsuperscript{" <> contents <> char '}' + +inlineToTexinfo (Subscript lst) = do + addToHeader $ "@macro textsubscript{text}\n" ++ + "@iftex\n" ++ + "@textsubscript{\\text\\}\n" ++ + "@end iftex\n" ++ + "@ifnottex\n" ++ + "_@{\\text\\@}\n" ++ + "@end ifnottex\n" ++ + "@end macro\n" + contents <- inlineListToTexinfo lst + return $ text "@textsubscript{" <> contents <> char '}' + +inlineToTexinfo (SmallCaps lst) = + inlineListToTexinfo lst >>= return . inCmd "sc" + +inlineToTexinfo (Code str) = do + return $ text $ "@code{" ++ stringToTexinfo str ++ "}" + +inlineToTexinfo (Quoted SingleQuote lst) = do + contents <- inlineListToTexinfo lst + return $ char '`' <> contents <> char '\'' + +inlineToTexinfo (Quoted DoubleQuote lst) = do + contents <- inlineListToTexinfo lst + return $ text "``" <> contents <> text "''" + +inlineToTexinfo (Cite _ lst) = + inlineListToTexinfo lst +inlineToTexinfo Apostrophe = return $ char '\'' +inlineToTexinfo EmDash = return $ text "---" +inlineToTexinfo EnDash = return $ text "--" +inlineToTexinfo Ellipses = return $ text "@dots{}" +inlineToTexinfo (Str str) = return $ text (stringToTexinfo str) +inlineToTexinfo (Math _ str) = return $ inCmd "math" $ text str +inlineToTexinfo (TeX str) = return $ text "@tex" $$ text str $$ text "@end tex" +inlineToTexinfo (HtmlInline _) = return empty +inlineToTexinfo (LineBreak) = return $ text "@*" +inlineToTexinfo Space = return $ char ' ' + +inlineToTexinfo (Link txt (src, _)) = do + case txt of + [Code x] | x == src -> -- autolink + do return $ text $ "@url{" ++ x ++ "}" + _ -> do contents <- inlineListToTexinfo txt + let src1 = stringToTexinfo src + return $ text ("@uref{" ++ src1 ++ ",") <> contents <> + char '}' + +inlineToTexinfo (Image alternate (source, _)) = do + content <- inlineListToTexinfo alternate + return $ text ("@image{" ++ base ++ ",,,") <> content <> text "," <> + text (ext ++ "}") + where + (revext, revbase) = break (=='.') (reverse source) + ext = reverse revext + base = case revbase of + ('.' : rest) -> reverse rest + _ -> reverse revbase + +inlineToTexinfo (Note contents) = do + contents' <- blockListToTexinfo contents + let rawnote = stripTrailingNewlines $ render contents' + let optNewline = "@end verbatim" `isSuffixOf` rawnote + return $ text "@footnote{" <> + text rawnote <> + (if optNewline then char '\n' else empty) <> + char '}' |