module Text.Pandoc.Writers.Docbook ( writeDocbook) where
import Text.Pandoc.Definition
import Text.Pandoc.XML
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Pandoc.Writers.Shared
import Text.Pandoc.Options
import Text.Pandoc.Templates (renderTemplate')
import Text.Pandoc.Readers.TeXMath
import Data.List ( stripPrefix, isPrefixOf, intercalate, isSuffixOf )
import Data.Char ( toLower )
import Data.Monoid ( Any(..) )
import Text.Pandoc.Highlighting ( languages, languagesByExtension )
import Text.Pandoc.Pretty
import Text.Pandoc.ImageSize
import qualified Text.Pandoc.Builder as B
import Text.TeXMath
import qualified Text.XML.Light as Xml
import Data.Generics (everywhere, mkT)
authorToDocbook :: WriterOptions -> [Inline] -> B.Inlines
authorToDocbook opts name' =
let name = render Nothing $ inlinesToDocbook opts name'
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
in B.rawInline "docbook" $ render colwidth $
if ',' `elem` name
then
let (lastname, rest) = break (==',') name
firstname = triml rest in
inTagsSimple "firstname" (text $ escapeStringForXML firstname) <>
inTagsSimple "surname" (text $ escapeStringForXML lastname)
else
let namewords = words name
lengthname = length namewords
(firstname, lastname) = case lengthname of
0 -> ("","")
1 -> ("", name)
n -> (intercalate " " (take (n1) namewords), last namewords)
in inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$
inTagsSimple "surname" (text $ escapeStringForXML lastname)
writeDocbook :: WriterOptions -> Pandoc -> String
writeDocbook opts (Pandoc meta blocks) =
let elements = hierarchicalize blocks
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
render' = render colwidth
opts' = if "/book>" `isSuffixOf`
(trimr $ writerTemplate opts)
then opts{ writerChapters = True }
else opts
startLvl = if writerChapters opts' then 0 else 1
auths' = map (authorToDocbook opts) $ docAuthors meta
meta' = B.setMeta "author" auths' meta
Just metadata = metaToJSON opts
(Just . render colwidth . (vcat .
(map (elementToDocbook opts' startLvl)) . hierarchicalize))
(Just . render colwidth . inlinesToDocbook opts')
meta'
main = render' $ vcat (map (elementToDocbook opts' startLvl) elements)
context = defField "body" main
$ defField "mathml" (case writerHTMLMathMethod opts of
MathML _ -> True
_ -> False)
$ metadata
in if writerStandalone opts
then renderTemplate' (writerTemplate opts) context
else main
elementToDocbook :: WriterOptions -> Int -> Element -> Doc
elementToDocbook opts _ (Blk block) = blockToDocbook opts block
elementToDocbook opts lvl (Sec _ _num (id',_,_) title elements) =
let elements' = if null elements
then [Blk (Para [])]
else elements
tag = case lvl of
n | n == 0 -> "chapter"
| n >= 1 && n <= 5 -> if writerDocbook5 opts
then "section"
else "sect" ++ show n
| otherwise -> "simplesect"
idAttr = [("id", writerIdentifierPrefix opts ++ id') | not (null id')]
nsAttr = if writerDocbook5 opts && lvl == 0 then [("xmlns", "http://docbook.org/ns/docbook"),("xmlns:xlink", "http://www.w3.org/1999/xlink")]
else []
attribs = nsAttr ++ idAttr
in inTags True tag attribs $
inTagsSimple "title" (inlinesToDocbook opts title) $$
vcat (map (elementToDocbook opts (lvl + 1)) elements')
blocksToDocbook :: WriterOptions -> [Block] -> Doc
blocksToDocbook opts = vcat . map (blockToDocbook opts)
plainToPara :: Block -> Block
plainToPara (Plain x) = Para x
plainToPara x = x
deflistItemsToDocbook :: WriterOptions -> [([Inline],[[Block]])] -> Doc
deflistItemsToDocbook opts items =
vcat $ map (\(term, defs) -> deflistItemToDocbook opts term defs) items
deflistItemToDocbook :: WriterOptions -> [Inline] -> [[Block]] -> Doc
deflistItemToDocbook opts term defs =
let def' = concatMap (map plainToPara) defs
in inTagsIndented "varlistentry" $
inTagsIndented "term" (inlinesToDocbook opts term) $$
inTagsIndented "listitem" (blocksToDocbook opts def')
listItemsToDocbook :: WriterOptions -> [[Block]] -> Doc
listItemsToDocbook opts items = vcat $ map (listItemToDocbook opts) items
listItemToDocbook :: WriterOptions -> [Block] -> Doc
listItemToDocbook opts item =
inTagsIndented "listitem" $ blocksToDocbook opts $ map plainToPara item
imageToDocbook :: WriterOptions -> Attr -> String -> Doc
imageToDocbook _ attr src = selfClosingTag "imagedata" $
("fileref", src) : idAndRole attr ++ dims
where
dims = go Width "width" ++ go Height "depth"
go dir dstr = case (dimension dir attr) of
Just a -> [(dstr, show a)]
Nothing -> []
blockToDocbook :: WriterOptions -> Block -> Doc
blockToDocbook _ Null = empty
blockToDocbook opts (Div (ident,_,_) [Para lst]) =
let attribs = [("id", ident) | not (null ident)] in
if hasLineBreaks lst
then flush $ nowrap $ inTags False "literallayout" attribs
$ inlinesToDocbook opts lst
else inTags True "para" attribs $ inlinesToDocbook opts lst
blockToDocbook opts (Div _ bs) = blocksToDocbook opts $ map plainToPara bs
blockToDocbook _ (Header _ _ _) = empty
blockToDocbook opts (Plain lst) = inlinesToDocbook opts lst
blockToDocbook opts (Para [Image attr txt (src,'f':'i':'g':':':_)]) =
let alt = inlinesToDocbook opts txt
capt = if null txt
then empty
else inTagsSimple "title" alt
in inTagsIndented "figure" $
capt $$
(inTagsIndented "mediaobject" $
(inTagsIndented "imageobject"
(imageToDocbook opts attr src)) $$
inTagsSimple "textobject" (inTagsSimple "phrase" alt))
blockToDocbook opts (Para lst)
| hasLineBreaks lst = flush $ nowrap $ inTagsSimple "literallayout" $ inlinesToDocbook opts lst
| otherwise = inTagsIndented "para" $ inlinesToDocbook opts lst
blockToDocbook opts (BlockQuote blocks) =
inTagsIndented "blockquote" $ blocksToDocbook opts blocks
blockToDocbook _ (CodeBlock (_,classes,_) str) =
text ("<programlisting" ++ lang ++ ">") <> cr <>
flush (text (escapeStringForXML str) <> cr <> text "</programlisting>")
where lang = if null langs
then ""
else " language=\"" ++ escapeStringForXML (head langs) ++
"\""
isLang l = map toLower l `elem` map (map toLower) languages
langsFrom s = if isLang s
then [s]
else languagesByExtension . map toLower $ s
langs = concatMap langsFrom classes
blockToDocbook opts (BulletList lst) =
let attribs = [("spacing", "compact") | isTightList lst]
in inTags True "itemizedlist" attribs $ listItemsToDocbook opts lst
blockToDocbook _ (OrderedList _ []) = empty
blockToDocbook opts (OrderedList (start, numstyle, _) (first:rest)) =
let numeration = case numstyle of
DefaultStyle -> []
Decimal -> [("numeration", "arabic")]
Example -> [("numeration", "arabic")]
UpperAlpha -> [("numeration", "upperalpha")]
LowerAlpha -> [("numeration", "loweralpha")]
UpperRoman -> [("numeration", "upperroman")]
LowerRoman -> [("numeration", "lowerroman")]
spacing = [("spacing", "compact") | isTightList (first:rest)]
attribs = numeration ++ spacing
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) =
let attribs = [("spacing", "compact") | isTightList $ concatMap snd lst]
in inTags True "variablelist" attribs $ deflistItemsToDocbook opts lst
blockToDocbook opts (RawBlock f str)
| f == "docbook" = text str
| f == "html" = if writerDocbook5 opts
then empty
else text str
| otherwise = empty
blockToDocbook _ HorizontalRule = empty
blockToDocbook opts (Table caption aligns widths headers rows) =
let captionDoc = if null caption
then empty
else inTagsIndented "title"
(inlinesToDocbook opts caption)
tableType = if isEmpty captionDoc then "informaltable" else "table"
percent w = show (truncate (100*w) :: Integer) ++ "*"
coltags = vcat $ zipWith (\w al -> selfClosingTag "colspec"
([("colwidth", percent w) | w > 0] ++
[("align", alignmentToString al)])) widths aligns
head' = if all null headers
then empty
else inTagsIndented "thead" $
tableRowToDocbook opts headers
body' = inTagsIndented "tbody" $
vcat $ map (tableRowToDocbook opts) rows
in inTagsIndented tableType $ captionDoc $$
(inTags True "tgroup" [("cols", show (length headers))] $
coltags $$ head' $$ body')
hasLineBreaks :: [Inline] -> Bool
hasLineBreaks = getAny . query isLineBreak . walk removeNote
where
removeNote :: Inline -> Inline
removeNote (Note _) = Str ""
removeNote x = x
isLineBreak :: Inline -> Any
isLineBreak LineBreak = Any True
isLineBreak _ = Any False
alignmentToString :: Alignment -> [Char]
alignmentToString alignment = case alignment of
AlignLeft -> "left"
AlignRight -> "right"
AlignCenter -> "center"
AlignDefault -> "left"
tableRowToDocbook :: WriterOptions
-> [[Block]]
-> Doc
tableRowToDocbook opts cols =
inTagsIndented "row" $ vcat $ map (tableItemToDocbook opts) cols
tableItemToDocbook :: WriterOptions
-> [Block]
-> Doc
tableItemToDocbook opts item =
inTags True "entry" [] $ vcat $ map (blockToDocbook opts) item
inlinesToDocbook :: WriterOptions -> [Inline] -> Doc
inlinesToDocbook opts lst = hcat $ map (inlineToDocbook opts) lst
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 opts (Span _ ils) =
inlinesToDocbook opts ils
inlineToDocbook _ (Code _ str) =
inTagsSimple "literal" $ text (escapeStringForXML str)
inlineToDocbook opts (Math t str)
| isMathML (writerHTMLMathMethod opts) =
case writeMathML dt <$> readTeX str of
Right r -> inTagsSimple tagtype
$ text $ Xml.ppcElement conf
$ fixNS
$ removeAttr r
Left _ -> inlinesToDocbook opts
$ texMathToInlines t str
| otherwise = inlinesToDocbook opts $ texMathToInlines t str
where (dt, tagtype) = case t of
InlineMath -> (DisplayInline,"inlineequation")
DisplayMath -> (DisplayBlock,"informalequation")
conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP
removeAttr e = e{ Xml.elAttribs = [] }
fixNS' qname = qname{ Xml.qPrefix = Just "mml" }
fixNS = everywhere (mkT fixNS')
inlineToDocbook _ (RawInline f x) | f == "html" || f == "docbook" = text x
| otherwise = empty
inlineToDocbook _ LineBreak = text "\n"
inlineToDocbook _ Space = space
inlineToDocbook _ SoftBreak = space
inlineToDocbook opts (Link attr txt (src, _))
| Just email <- stripPrefix "mailto:" src =
let emailLink = inTagsSimple "email" $ text $
escapeStringForXML $ email
in case txt of
[Str s] | escapeURI s == email -> emailLink
_ -> inlinesToDocbook opts txt <+>
char '(' <> emailLink <> char ')'
| otherwise =
(if isPrefixOf "#" src
then inTags False "link" $ ("linkend", drop 1 src) : idAndRole attr
else if writerDocbook5 opts
then inTags False "link" $ ("xlink:href", src) : idAndRole attr
else inTags False "ulink" $ ("url", src) : idAndRole attr ) $
inlinesToDocbook opts txt
inlineToDocbook opts (Image attr _ (src, tit)) =
let titleDoc = if null tit
then empty
else inTagsIndented "objectinfo" $
inTagsIndented "title" (text $ escapeStringForXML tit)
in inTagsIndented "inlinemediaobject" $ inTagsIndented "imageobject" $
titleDoc $$ imageToDocbook opts attr src
inlineToDocbook opts (Note contents) =
inTagsIndented "footnote" $ blocksToDocbook opts contents
isMathML :: HTMLMathMethod -> Bool
isMathML (MathML _) = True
isMathML _ = False
idAndRole :: Attr -> [(String, String)]
idAndRole (id',cls,_) = ident ++ role
where
ident = if null id'
then []
else [("id", id')]
role = if null cls
then []
else [("role", unwords cls)]