@@ -0,0 +1,236 @@
1+{-
2+Copyright (C) 2006 John MacFarlane <jgm at berkeley dot edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Writers.Docbook
21+ Copyright : Copyright (C) 2006 John MacFarlane
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : John MacFarlane <jgm at berkeley dot edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of 'Pandoc' documents to Docbook XML.
29+-}
30+module Text.Pandoc.Writers.Docbook (
31+ writeDocbook
32+ ) where
33+import Text.Pandoc.Definition
34+import Text.Pandoc.Shared
35+import Text.Pandoc.Writers.HTML ( stringToSmartHtml, stringToHtml )
36+import Text.Html ( stringToHtmlString )
37+import Text.Regex ( mkRegex, matchRegex )
38+import Data.Char ( toLower )
39+import Data.List ( isPrefixOf, partition )
40+import Text.PrettyPrint.HughesPJ hiding ( Str )
41+
42+-- | Data structure for defining hierarchical Pandoc documents
43+data Element = Blk Block
44+ | Sec [Inline] [Element] deriving (Eq, Read, Show)
45+
46+-- | Returns true on Header block with level at least 'level'
47+headerAtLeast :: Int -> Block -> Bool
48+headerAtLeast level (Header x _) = x <= level
49+headerAtLeast level _ = False
50+
51+-- | Convert list of Pandoc blocks into list of Elements (hierarchical)
52+hierarchicalize :: [Block] -> [Element]
53+hierarchicalize [] = []
54+hierarchicalize (block:rest) =
55+ case block of
56+ (Header level title) -> let (thisSection, rest') = break (headerAtLeast level) rest in
57+ (Sec title (hierarchicalize thisSection)):(hierarchicalize rest')
58+ x -> (Blk x):(hierarchicalize rest)
59+
60+-- | Convert list of authors to a docbook <author> section
61+authorToDocbook :: WriterOptions -> [Char] -> Doc
62+authorToDocbook options name = indentedInTags options "author" $
63+ if ',' `elem` name
64+ then -- last name first
65+ let (lastname, rest) = break (==',') name
66+ firstname = removeLeadingSpace rest in
67+ inTags "firstname" (text $ stringToXML options firstname) <>
68+ inTags "surname" (text $ stringToXML options lastname)
69+ else -- last name last
70+ let namewords = words name
71+ lengthname = length namewords
72+ (firstname, lastname) = case lengthname of
73+ 0 -> ("","")
74+ 1 -> ("", name)
75+ n -> (joinWithSep " " (take (n-1) namewords), last namewords) in
76+ inTags "firstname" (text $ stringToXML options firstname) $$
77+ inTags "surname" (text $ stringToXML options lastname)
78+
79+-- | Convert Pandoc document to string in Docbook format.
80+writeDocbook :: WriterOptions -> Pandoc -> String
81+writeDocbook options (Pandoc (Meta title authors date) blocks) =
82+ let head = if (writerStandalone options)
83+ then text (writerHeader options)
84+ else empty
85+ meta = if (writerStandalone options)
86+ then indentedInTags options "articleinfo" $
87+ (inTags "title" (inlinesToDocbook options title)) $$
88+ (vcat (map (authorToDocbook options) authors)) $$
89+ (inTags "date" (text date))
90+ else empty
91+ blocks' = replaceReferenceLinks blocks
92+ (noteBlocks, blocks'') = partition isNoteBlock blocks'
93+ options' = options {writerNotes = noteBlocks}
94+ elements = hierarchicalize blocks''
95+ body = text (writerIncludeBefore options') <>
96+ vcat (map (elementToDocbook options') elements) $$
97+ text (writerIncludeAfter options')
98+ body' = if writerStandalone options'
99+ then indentedInTags options' "article" (meta $$ body)
100+ else body in
101+ render $ head $$ body' <> text "\n"
102+
103+-- | Put the supplied contents between start and end tags of tagType,
104+-- with specified attributes.
105+inTagsWithAttrib :: String -> [(String, String)] -> Doc -> Doc
106+inTagsWithAttrib tagType attribs contents = text ("<" ++ tagType ++
107+ (concatMap (\(a, b) -> " " ++ attributeStringToXML a ++
108+ "=\"" ++ attributeStringToXML b ++ "\"") attribs)) <>
109+ if isEmpty contents
110+ then text " />" -- self-closing tag
111+ else text ">" <> contents <> text ("</" ++ tagType ++ ">")
112+
113+-- | Put the supplied contents between start and end tags of tagType.
114+inTags :: String -> Doc -> Doc
115+inTags tagType contents = inTagsWithAttrib tagType [] contents
116+
117+-- | Put the supplied contents in indented block btw start and end tags.
118+indentedInTags :: WriterOptions -> [Char] -> Doc -> Doc
119+indentedInTags options tagType contents = text ("<" ++ tagType ++ ">") $$
120+ nest 2 contents $$ text ("</" ++ tagType ++ ">")
121+
122+-- | Convert an Element to Docbook.
123+elementToDocbook :: WriterOptions -> Element -> Doc
124+elementToDocbook options (Blk block) = blockToDocbook options block
125+elementToDocbook options (Sec title elements) =
126+ -- Docbook doesn't allow sections with no content, so insert some if needed
127+ let elements' = if null elements
128+ then [Blk (Para [])]
129+ else elements in
130+ indentedInTags options "section" $
131+ inTags "title" (wrap options title) $$
132+ vcat (map (elementToDocbook options) elements')
133+
134+-- | Convert a list of Pandoc blocks to Docbook.
135+blocksToDocbook :: WriterOptions -> [Block] -> Doc
136+blocksToDocbook options = vcat . map (blockToDocbook options)
137+
138+-- | Convert a list of lists of blocks to a list of Docbook list items.
139+listItemsToDocbook :: WriterOptions -> [[Block]] -> Doc
140+listItemsToDocbook options items =
141+ vcat $ map (listItemToDocbook options) items
142+
143+-- | Convert a list of blocks into a Docbook list item.
144+listItemToDocbook :: WriterOptions -> [Block] -> Doc
145+listItemToDocbook options item =
146+ let plainToPara (Plain x) = Para x
147+ plainToPara y = y in
148+ let item' = map plainToPara item in
149+ indentedInTags options "listitem" (blocksToDocbook options item')
150+
151+-- | Convert a Pandoc block element to Docbook.
152+blockToDocbook :: WriterOptions -> Block -> Doc
153+blockToDocbook options Blank = text ""
154+blockToDocbook options Null = empty
155+blockToDocbook options (Plain lst) = wrap options lst
156+blockToDocbook options (Para lst) =
157+ indentedInTags options "para" (wrap options lst)
158+blockToDocbook options (BlockQuote blocks) =
159+ indentedInTags options "blockquote" (blocksToDocbook options blocks)
160+blockToDocbook options (CodeBlock str) =
161+ text "<programlisting>" <> (cdata str) <> text "</programlisting>"
162+blockToDocbook options (BulletList lst) =
163+ indentedInTags options "itemizedlist" $ listItemsToDocbook options lst
164+blockToDocbook options (OrderedList lst) =
165+ indentedInTags options "orderedlist" $ listItemsToDocbook options lst
166+blockToDocbook options (RawHtml str) = text str -- raw XML block
167+blockToDocbook options HorizontalRule = empty -- not semantic
168+blockToDocbook options (Note _ _) = empty -- shouldn't occur
169+blockToDocbook options (Key _ _) = empty -- shouldn't occur
170+blockToDocbook options _ = indentedInTags options "para" (text "Unknown block type")
171+
172+-- | Put string in CDATA section
173+cdata :: String -> Doc
174+cdata str = text $ "<![CDATA[" ++ str ++ "]]>"
175+
176+-- | Take list of inline elements and return wrapped doc.
177+wrap :: WriterOptions -> [Inline] -> Doc
178+wrap options lst = fsep $ map (hcat . (map (inlineToDocbook options))) (splitBySpace lst)
179+
180+-- | Escape a string for XML (with "smart" option if specified).
181+stringToXML :: WriterOptions -> String -> String
182+stringToXML options = if writerSmart options
183+ then stringToSmartHtml
184+ else stringToHtml
185+
186+-- | Escape string to XML appropriate for attributes
187+attributeStringToXML :: String -> String
188+attributeStringToXML = gsub "\"" """ . codeStringToXML
189+
190+-- | Escape a literal string for XML.
191+codeStringToXML :: String -> String
192+codeStringToXML = gsub "<" "<" . gsub "&" "&"
193+
194+-- | Convert a list of inline elements to Docbook.
195+inlinesToDocbook :: WriterOptions -> [Inline] -> Doc
196+inlinesToDocbook options lst = hcat (map (inlineToDocbook options) lst)
197+
198+-- | Convert an inline element to Docbook.
199+inlineToDocbook :: WriterOptions -> Inline -> Doc
200+inlineToDocbook options (Str str) = text $ stringToXML options str
201+inlineToDocbook options (Emph lst) =
202+ inTags "emphasis" (inlinesToDocbook options lst)
203+inlineToDocbook options (Strong lst) =
204+ inTagsWithAttrib "emphasis" [("role", "strong")]
205+ (inlinesToDocbook options lst)
206+inlineToDocbook options (Code str) =
207+ inTags "literal" $ text (codeStringToXML str)
208+inlineToDocbook options (TeX str) = inlineToDocbook options (Code str)
209+inlineToDocbook options (HtmlInline str) = empty
210+inlineToDocbook options LineBreak =
211+ text $ "<literallayout></literallayout>"
212+inlineToDocbook options Space = char ' '
213+inlineToDocbook options (Link txt (Src src tit)) =
214+ case (matchRegex (mkRegex "mailto:(.*)") src) of
215+ Just [addr] -> inTags "email" $ text (codeStringToXML addr)
216+ Nothing -> inTagsWithAttrib "ulink" [("url", src)] $
217+ inlinesToDocbook options txt
218+inlineToDocbook options (Link text (Ref ref)) = empty -- shouldn't occur
219+inlineToDocbook options (Image alt (Src src tit)) =
220+ let titleDoc = if null tit
221+ then empty
222+ else indentedInTags options "objectinfo" $
223+ indentedInTags options "title"
224+ (text $ stringToXML options tit) in
225+ indentedInTags options "inlinemediaobject" $
226+ indentedInTags options "imageobject" $
227+ titleDoc $$ inTagsWithAttrib "imagedata" [("fileref", src)] empty
228+inlineToDocbook options (Image alternate (Ref ref)) = empty --shouldn't occur
229+inlineToDocbook options (NoteRef ref) =
230+ let notes = writerNotes options
231+ hits = filter (\(Note r _) -> r == ref) notes in
232+ if null hits
233+ then empty
234+ else let (Note _ contents) = head hits in
235+ indentedInTags options "footnote" $ blocksToDocbook options contents
236+inlineToDocbook options _ = empty