diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/Docbook.hs')
| -rw-r--r-- | src/Text/Pandoc/Writers/Docbook.hs | 199 |
1 files changed, 104 insertions, 95 deletions
diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index ecd27ee0c..e34b1959c 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -30,16 +30,35 @@ Conversion of 'Pandoc' documents to Docbook XML. module Text.Pandoc.Writers.Docbook ( writeDocbook) where import Text.Pandoc.Definition import Text.Pandoc.Shared -import Text.Pandoc.Entities ( escapeStringForXML ) -import Data.Char ( toLower, ord ) -import Data.List ( isPrefixOf, partition, drop ) +import Data.List ( isPrefixOf, drop ) import Text.PrettyPrint.HughesPJ hiding ( Str ) - -- -- code to format XML -- +-- | Escape one character as needed for XML. +escapeCharForXML :: Char -> String +escapeCharForXML x = case x of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\160' -> " " + c -> [c] + +-- | True if the character needs to be escaped. +needsEscaping :: Char -> Bool +needsEscaping c = c `elem` "&<>\"\160" + +-- | Escape string as needed for XML. Entity references are not preserved. +escapeStringForXML :: String -> String +escapeStringForXML "" = "" +escapeStringForXML str = + case break needsEscaping str of + (okay, "") -> okay + (okay, (c:cs)) -> okay ++ escapeCharForXML c ++ escapeStringForXML cs + -- | Return a text object with a string of formatted XML attributes. attributeList :: [(String, String)] -> Doc attributeList = text . concatMap @@ -52,10 +71,10 @@ inTags:: Bool -> String -> [(String, String)] -> Doc -> Doc inTags isIndented tagType attribs contents = let openTag = char '<' <> text tagType <> attributeList attribs <> char '>' - closeTag = text "</" <> text tagType <> char '>' in - if isIndented - then openTag $$ nest 2 contents $$ closeTag - else openTag <> contents <> closeTag + closeTag = text "</" <> text tagType <> char '>' + in if isIndented + then openTag $$ nest 2 contents $$ closeTag + else openTag <> contents <> closeTag -- | Return a self-closing tag of tagType with specified attributes selfClosingTag :: String -> [(String, String)] -> Doc @@ -79,42 +98,42 @@ 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) + 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 -> (joinWithSep " " (take (n-1) namewords), last namewords) in - inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$ - inTagsSimple "surname" (text $ escapeStringForXML lastname) + let namewords = words name + lengthname = length namewords + (firstname, lastname) = case lengthname of + 0 -> ("","") + 1 -> ("", name) + n -> (joinWithSep " " (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 + 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 "" + 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 @@ -123,10 +142,10 @@ 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') + 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 @@ -145,30 +164,27 @@ deflistItemsToDocbook opts 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') + 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 +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 = - let item' = map plainToPara item in - inTagsIndented "listitem" (blocksToDocbook opts item') + inTagsIndented "listitem" $ blocksToDocbook opts $ map plainToPara item -- | Convert a Pandoc block element to Docbook. blockToDocbook :: WriterOptions -> Block -> Doc blockToDocbook opts Null = empty blockToDocbook opts (Plain lst) = wrap opts lst -blockToDocbook opts (Para lst) = - inTagsIndented "para" (wrap opts lst) +blockToDocbook opts (Para lst) = inTagsIndented "para" $ wrap opts lst blockToDocbook opts (BlockQuote blocks) = - inTagsIndented "blockquote" (blocksToDocbook opts blocks) + inTagsIndented "blockquote" $ blocksToDocbook opts blocks blockToDocbook opts (CodeBlock str) = text "<screen>\n" <> text (escapeStringForXML str) <> text "\n</screen>" blockToDocbook opts (BulletList lst) = @@ -198,16 +214,16 @@ blockToDocbook opts (Table caption aligns widths headers rows) = 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) + tableType = if isEmpty captionDoc then "informaltable" else "table" + in inTagsIndented tableType $ captionDoc $$ + (colHeadsToDocbook opts alignStrings widths headers) $$ + (vcat $ map (tableRowToDocbook opts alignStrings) rows) 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 + let heads = zipWith3 (\align width item -> + tableItemToDocbook opts "th" align width item) + alignStrings widths headers + in inTagsIndented "tr" $ vcat heads alignmentToString alignment = case alignment of AlignLeft -> "left" @@ -215,20 +231,16 @@ alignmentToString alignment = case alignment of AlignCenter -> "center" AlignDefault -> "left" -tableRowToDocbook opts aligns cols = - inTagsIndented "tr" $ vcat $ zipWith3 (tableItemToDocbook opts "td") aligns (repeat 0) cols +tableRowToDocbook opts aligns cols = inTagsIndented "tr" $ + vcat $ zipWith3 (tableItemToDocbook opts "td") aligns (repeat 0) cols tableItemToDocbook opts tag align width item = let attrib = [("align", align)] ++ - if (width /= 0) - then [("style", "{width: " ++ - show (truncate (100*width)) ++ "%;}")] - else [] in - inTags True tag attrib $ vcat $ map (blockToDocbook opts) item - --- | Put string in CDATA section -cdata :: String -> Doc -cdata str = text $ "<![CDATA[" ++ str ++ "]]>" + if width /= 0 + then [("style", "{width: " ++ + show (truncate (100*width)) ++ "%;}")] + else [] + in inTags True tag attrib $ vcat $ map (blockToDocbook opts) item -- | Take list of inline elements and return wrapped doc. wrap :: WriterOptions -> [Inline] -> Doc @@ -236,25 +248,24 @@ wrap opts lst = fsep $ map (inlinesToDocbook opts) (splitBy Space lst) -- | Convert a list of inline elements to Docbook. inlinesToDocbook :: WriterOptions -> [Inline] -> Doc -inlinesToDocbook opts lst = hcat (map (inlineToDocbook opts) lst) +inlinesToDocbook opts lst = hcat $ map (inlineToDocbook opts) lst -- | Convert an inline element to Docbook. inlineToDocbook :: WriterOptions -> Inline -> Doc inlineToDocbook opts (Str str) = text $ escapeStringForXML str inlineToDocbook opts (Emph lst) = - inTagsSimple "emphasis" (inlinesToDocbook opts lst) + inTagsSimple "emphasis" $ inlinesToDocbook opts lst inlineToDocbook opts (Strong lst) = - inTags False "emphasis" [("role", "strong")] - (inlinesToDocbook opts lst) + inTags False "emphasis" [("role", "strong")] $ inlinesToDocbook opts lst inlineToDocbook opts (Strikeout lst) = - inTags False "emphasis" [("role", "strikethrough")] - (inlinesToDocbook opts lst) + inTags False "emphasis" [("role", "strikethrough")] $ + inlinesToDocbook opts lst inlineToDocbook opts (Superscript lst) = - inTagsSimple "superscript" (inlinesToDocbook opts lst) + inTagsSimple "superscript" $ inlinesToDocbook opts lst inlineToDocbook opts (Subscript lst) = - inTagsSimple "subscript" (inlinesToDocbook opts lst) + inTagsSimple "subscript" $ inlinesToDocbook opts lst inlineToDocbook opts (Quoted _ lst) = - inTagsSimple "quote" (inlinesToDocbook opts lst) + inTagsSimple "quote" $ inlinesToDocbook opts lst inlineToDocbook opts Apostrophe = char '\'' inlineToDocbook opts Ellipses = text "…" inlineToDocbook opts EmDash = text "—" @@ -263,26 +274,24 @@ inlineToDocbook opts (Code str) = inTagsSimple "literal" $ text (escapeStringForXML str) inlineToDocbook opts (TeX str) = inlineToDocbook opts (Code str) inlineToDocbook opts (HtmlInline str) = empty -inlineToDocbook opts LineBreak = - text $ "<literallayout></literallayout>" +inlineToDocbook opts LineBreak = text $ "<literallayout></literallayout>" inlineToDocbook opts Space = char ' ' inlineToDocbook opts (Link txt (src, tit)) = 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 + 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 opts (Image alt (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)] + inTagsIndented "title" (text $ escapeStringForXML tit) + in inTagsIndented "inlinemediaobject" $ inTagsIndented "imageobject" $ + titleDoc $$ selfClosingTag "imagedata" [("fileref", src)] inlineToDocbook opts (Note contents) = inTagsIndented "footnote" $ blocksToDocbook opts contents |