@@ -0,0 +1,459 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-
3+Copyright (C) 2006-2010 John MacFarlane <jgm@berkeley.edu>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+-}
19+
20+{- |
21+ Module : Text.Pandoc.Writers.PseudoPod
22+ Copyright : Copyright (C) 2006-2010 John MacFarlane
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : John MacFarlane <jgm@berkeley.edu>
26+ Stability : alpha
27+ Portability : portable
28+
29+Conversion of 'Pandoc' documents to PseudoPod-formatted plain text.
30+
31+PseudoPod: <http://daringfireball.net/projects/PseudoPod/>
32+-}
33+module Text.Pandoc.Writers.PseudoPod (writePseudoPod) where
34+import Text.Pandoc.Definition
35+import Text.Pandoc.Generic
36+import Text.Pandoc.Templates (renderTemplate)
37+import Text.Pandoc.Shared
38+import Text.Pandoc.Parsing hiding (blankline)
39+import Text.ParserCombinators.Parsec ( runParser, GenParser )
40+import Data.List ( intersperse, transpose )
41+import Text.Pandoc.Pretty
42+import Control.Monad.State
43+
44+type Refs = [([Inline], Target)]
45+data WriterState = WriterState { stRefs :: Refs
46+ , stPlain :: Bool }
47+
48+-- | Convert Pandoc to PseudoPod.
49+writePseudoPod :: WriterOptions -> Pandoc -> String
50+writePseudoPod opts document =
51+ evalState (pandocToPseudoPod opts document) WriterState{stRefs = []
52+ , stPlain = False }
53+
54+-- | Return PseudoPod representation of document.
55+pandocToPseudoPod :: WriterOptions -> Pandoc -> State WriterState String
56+pandocToPseudoPod opts (Pandoc (Meta title authors date) blocks) = do
57+ title' <- inlineListToPseudoPod opts title
58+ authors' <- mapM (inlineListToPseudoPod opts) authors
59+ date' <- inlineListToPseudoPod opts date
60+ let titleblock = not $ null title && null authors && null date
61+ let headerBlocks = filter isHeaderBlock blocks
62+ let toc = if writerTableOfContents opts
63+ then tableOfContents opts headerBlocks
64+ else empty
65+ body <- blockListToPseudoPod opts blocks
66+ st' <- get -- note that the notes may contain refs
67+ refs' <- refsToPseudoPod opts (reverse $ stRefs st')
68+ let colwidth = if writerWrapText opts
69+ then Just $ writerColumns opts
70+ else Nothing
71+ let main = render colwidth $ body <>
72+ (if isEmpty refs' then empty else blankline <> refs')
73+ let context = writerVariables opts ++
74+ [ ("toc", render colwidth toc)
75+ , ("body", main)
76+ , ("title", render colwidth title')
77+ , ("date", render colwidth date')
78+ ] ++
79+ [ ("titleblock", "yes") | titleblock ] ++
80+ [ ("author", render colwidth a) | a <- authors' ]
81+ if writerStandalone opts
82+ then return $ renderTemplate context $ writerTemplate opts
83+ else return main
84+
85+-- | Return PseudoPod representation of reference key table.
86+refsToPseudoPod :: WriterOptions -> Refs -> State WriterState Doc
87+refsToPseudoPod opts refs = mapM (keyToPseudoPod opts) refs >>= return . vcat
88+
89+-- | Return PseudoPod representation of a reference key.
90+keyToPseudoPod :: WriterOptions
91+ -> ([Inline], (String, String))
92+ -> State WriterState Doc
93+keyToPseudoPod opts (label, (src, tit)) = do
94+ label' <- inlineListToPseudoPod opts label
95+ let tit' = if null tit
96+ then empty
97+ else space <> "\"" <> text tit <> "\""
98+ return $ nest 2 $ hang 2
99+ ("[" <> label' <> "]:" <> space) (text src <> tit')
100+
101+-- | Escape special characters for PseudoPod.
102+escapeString :: String -> String
103+escapeString = escapeStringUsing pseudopodEscapes
104+ where pseudopodEscapes = entityEscapes
105+
106+-- | pod-ish entity escapes, E<>
107+entityEscapes :: [(Char,String)]
108+entityEscapes = [('>', "E<gt>")]
109+
110+-- | Construct table of contents from list of header blocks.
111+tableOfContents :: WriterOptions -> [Block] -> Doc
112+tableOfContents opts headers =
113+ let opts' = opts { writerIgnoreNotes = True }
114+ contents = BulletList $ map elementToListItem $ hierarchicalize headers
115+ in evalState (blockToPseudoPod opts' contents) WriterState{ stRefs = []
116+ , stPlain = False }
117+
118+-- | Converts an Element to a list item for a table of contents,
119+elementToListItem :: Element -> [Block]
120+elementToListItem (Blk _) = []
121+elementToListItem (Sec _ _ _ headerText subsecs) = [Plain headerText] ++
122+ if null subsecs
123+ then []
124+ else [BulletList $ map elementToListItem subsecs]
125+
126+attrsToPseudoPod :: Attr -> Doc
127+attrsToPseudoPod attribs = braces $ hsep [attribId, attribClasses, attribKeys]
128+ where attribId = case attribs of
129+ ([],_,_) -> empty
130+ (i,_,_) -> "#" <> text i
131+ attribClasses = case attribs of
132+ (_,[],_) -> empty
133+ (_,cs,_) -> hsep $
134+ map (text . ('.':))
135+ cs
136+ attribKeys = case attribs of
137+ (_,_,[]) -> empty
138+ (_,_,ks) -> hsep $
139+ map (\(k,v) -> text k
140+ <> "=\"" <> text v <> "\"") ks
141+
142+-- | Ordered list start parser for use in Para below.
143+olMarker :: GenParser Char ParserState Char
144+olMarker = do (start, style', delim) <- anyOrderedListMarker
145+ if delim == Period &&
146+ (style' == UpperAlpha || (style' == UpperRoman &&
147+ start `elem` [1, 5, 10, 50, 100, 500, 1000]))
148+ then spaceChar >> spaceChar
149+ else spaceChar
150+
151+-- | True if string begins with an ordered list marker
152+beginsWithOrderedListMarker :: String -> Bool
153+beginsWithOrderedListMarker str =
154+ case runParser olMarker defaultParserState "para start" (take 10 str) of
155+ Left _ -> False
156+ Right _ -> True
157+
158+-- | Convert Pandoc block element to PseudoPod.
159+blockToPseudoPod :: WriterOptions -- ^ Options
160+ -> Block -- ^ Block element
161+ -> State WriterState Doc
162+blockToPseudoPod _ Null = return empty
163+blockToPseudoPod opts (Plain inlines) = do
164+ contents <- inlineListToPseudoPod opts inlines
165+ return $ contents <> cr
166+
167+
168+blockToPseudoPod opts (Para inlines) = do
169+ contents <- inlineListToPseudoPod opts inlines
170+ -- escape if para starts with ordered list marker
171+ st <- get
172+ let esc = if (not (writerStrictMarkdown opts)) &&
173+ not (stPlain st) &&
174+ beginsWithOrderedListMarker (render Nothing contents)
175+ then text "\\"
176+ else empty
177+ return $ esc <> contents <> blankline
178+blockToPseudoPod _ (RawBlock f str)
179+ | f == "html" || f == "latex" || f == "tex" || f == "PseudoPod" = do
180+ st <- get
181+ if stPlain st
182+ then return empty
183+ else return $ text str <> text "\n"
184+blockToPseudoPod _ (RawBlock _ _) = return empty
185+
186+-- | No horizontal rules, leave a space
187+blockToPseudoPod _ HorizontalRule =
188+ return $ blankline <> blankline <> blankline
189+
190+-- | =headN <content> - DONE
191+blockToPseudoPod opts (Header level inlines) = do
192+ contents <- inlineListToPseudoPod opts inlines
193+ return $ "=head" <> text (show level) <> " " <> contents <> blankline
194+
195+{-
196+blockToPseudoPod opts (CodeBlock (_,classes,_) str)
197+ | "haskell" `elem` classes && "literate" `elem` classes &&
198+ writerLiterateHaskell opts =
199+ return $ prefixed "> " (text str) <> blankline
200+-}
201+
202+-- | indent 3 spaces - DONE
203+blockToPseudoPod _ (CodeBlock _ str) = return $
204+ nest 3 (text str) <> blankline
205+
206+{-
207+ if writerStrictMarkdown opts || attribs == nullAttr
208+ then nest (writerTabStop opts) (text str) <> blankline
209+ else -- use delimited code block
210+ flush (tildes <> space <> attrs <> cr <> text str <>
211+ cr <> tildes) <> blankline
212+ where tildes = text "~~~~"
213+ attrs = attrsToPseudoPod attribs
214+-}
215+
216+-- | =begin blockquote ?
217+blockToPseudoPod opts (BlockQuote blocks) = do
218+ contents <- blockListToPseudoPod opts blocks
219+ return $ "=begin blockquote" <> blankline <> contents <> blankline <> "=end blockquote" <> blankline
220+
221+-- | =begin table <caption> / =headrow / =row / =cell / =bodyrows / =row / =cell / =end table
222+blockToPseudoPod opts (Table caption _ _ headers rows) = do
223+ caption' <- inlineListToPseudoPod opts caption
224+ headers' <- mapM (blockListToPseudoPod opts) headers
225+
226+ rawRows <- mapM (mapM (blockListToPseudoPod opts)) rows
227+ let makeRow = hcat . intersperse (text("\n=cell "))
228+ let makeRowBlock = hcat . intersperse (text("\n=row\n\n=cell "))
229+
230+ let rows' = map makeRow rawRows
231+ let rows'' = makeRowBlock rows'
232+ let rows''' = "=row" <> blankline <> "=cell " <> rows''
233+
234+ let head' = makeRow headers'
235+ let head'' = "=row" <> blankline <> "=cell " <> head'
236+
237+ return $ "=begin table " <> caption' <> blankline <> "=headrow" <> blankline <> head'' <> blankline <> "=bodyrows" <> blankline <> rows''' <> blankline <> "=end table" <> blankline
238+
239+-- | =over / =item * / =back
240+blockToPseudoPod opts (BulletList items) = do
241+ contents <- mapM (bulletListItemToPseudoPod opts) items
242+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
243+
244+
245+-- | =over / =item N. / =back
246+blockToPseudoPod opts (OrderedList attribs items) = do
247+ let markers = orderedListMarkers attribs
248+ let markers' = map (\m -> if length m < 3
249+ then m ++ replicate (3 - length m) ' '
250+ else m) markers
251+ contents <- mapM (\(item, num) -> orderedListItemToPseudoPod opts item num) $
252+ zip markers' items
253+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
254+-- return $ cat contents <> blankline
255+
256+blockToPseudoPod opts (DefinitionList items) = do
257+ contents <- mapM (definitionListItemToPseudoPod opts) items
258+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
259+
260+-- | bullet list -> =item *
261+bulletListItemToPseudoPod :: WriterOptions -> [Block] -> State WriterState Doc
262+bulletListItemToPseudoPod opts items = do
263+ contents <- blockListToPseudoPod opts items
264+ return $ "=item *" <> blankline <> contents <> blankline
265+
266+-- | Convert ordered list item (a list of blocks) to PseudoPod.
267+orderedListItemToPseudoPod :: WriterOptions -- ^ options
268+ -> String -- ^ list item marker
269+ -> [Block] -- ^ list item (list of blocks)
270+ -> State WriterState Doc
271+orderedListItemToPseudoPod opts marker items = do
272+ contents <- blockListToPseudoPod opts items
273+ return $ "=item " <> (text marker) <> blankline <> contents <> blankline
274+
275+{-
276+ let sps = case length marker - writerTabStop opts of
277+ n | n > 0 -> text $ replicate n ' '
278+ _ -> text " "
279+ let start = text marker <> sps
280+ return $ hang (writerTabStop opts) start $ contents <> cr
281+-}
282+
283+{-
284+-- | Convert definition list item (label, list of blocks) to markdown.
285+definitionListItemToPseudoPod :: WriterOptions
286+ -> ([Inline],[[Block]])
287+ -> State WriterState Doc
288+definitionListItemToPseudoPod opts (label, defs) = do
289+ labelText <- inlineListToPseudoPod opts label
290+ let tabStop = writerTabStop opts
291+ st <- get
292+ let leader = if stPlain st then " " else " ~"
293+ let sps = case writerTabStop opts - 3 of
294+ n | n > 0 -> text $ replicate n ' '
295+ _ -> text " "
296+ defs' <- mapM (mapM (blockToPseudoPod opts)) defs
297+ let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs'
298+ return $ labelText <> cr <> contents <> cr
299+-}
300+
301+-- | Convert definition list item (label, list of blocks) to PseudoPod.
302+-- | =over / =item FOO / para / =back
303+definitionListItemToPseudoPod :: WriterOptions
304+ -> ([Inline],[[Block]])
305+ -> State WriterState Doc
306+definitionListItemToPseudoPod opts (label, defs) = do
307+ labelText <- inlineListToPseudoPod opts label
308+ -- each call to definitonListItemToPseudoPod is one label, which can have multiple defintions. (Each definition is a [Block].)
309+
310+ defs' <- mapM (blockListToPseudoPod opts) defs
311+-- let contents = vcat $ map (\d -> "=item") $ vcat d <> cr) defs'
312+ return $ "=item " <> labelText <> blankline <> vcat defs' <> blankline
313+
314+
315+-- | Convert list of Pandoc block elements to PseudoPod.
316+blockListToPseudoPod :: WriterOptions -- ^ Options
317+ -> [Block] -- ^ List of block elements
318+ -> State WriterState Doc
319+blockListToPseudoPod opts blocks =
320+ mapM (blockToPseudoPod opts) (fixBlocks blocks) >>= return . cat
321+ -- insert comment between list and indented code block, or the
322+ -- code block will be treated as a list continuation paragraph
323+ where fixBlocks (b : CodeBlock attr x : rest)
324+ | (writerStrictMarkdown opts || attr == nullAttr) && isListBlock b =
325+ b : RawBlock "html" "<!-- -->\n" : CodeBlock attr x :
326+ fixBlocks rest
327+ fixBlocks (x : xs) = x : fixBlocks xs
328+ fixBlocks [] = []
329+ isListBlock (BulletList _) = True
330+ isListBlock (OrderedList _ _) = True
331+ isListBlock (DefinitionList _) = True
332+ isListBlock _ = False
333+
334+-- | Convert list of Pandoc inline elements to PseudoPod.
335+inlineListToPseudoPod :: WriterOptions -> [Inline] -> State WriterState Doc
336+inlineListToPseudoPod opts lst =
337+ mapM (inlineToPseudoPod opts) lst >>= return . cat
338+
339+escapeSpaces :: Inline -> Inline
340+escapeSpaces (Str s) = Str $ substitute " " "\\ " s
341+escapeSpaces Space = Str "\\ "
342+escapeSpaces x = x
343+
344+-- | Convert Pandoc inline element to PseudoPod.
345+inlineToPseudoPod :: WriterOptions -> Inline -> State WriterState Doc
346+
347+-- | B< > - DONE
348+inlineToPseudoPod opts (Emph lst) = do
349+ contents <- inlineListToPseudoPod opts lst
350+ return $ "B<" <> contents <> ">"
351+
352+-- | B< > - DONE
353+inlineToPseudoPod opts (Strong lst) = do
354+ contents <- inlineListToPseudoPod opts lst
355+ return $ "B<" <> contents <> ">"
356+
357+inlineToPseudoPod opts (Strikeout lst) = inlineListToPseudoPod opts lst
358+{-
359+inlineToPseudoPod opts (Strikeout lst) = do
360+ contents <- inlineListToPseudoPod opts lst
361+ return $ "~~" <> contents <> "~~"
362+-}
363+
364+-- | G<>
365+inlineToPseudoPod opts (Superscript lst) = do
366+ let lst' = bottomUp escapeSpaces lst
367+ contents <- inlineListToPseudoPod opts lst'
368+ return $ "G<" <> contents <> ">"
369+
370+-- | H<>
371+inlineToPseudoPod opts (Subscript lst) = do
372+ let lst' = bottomUp escapeSpaces lst
373+ contents <- inlineListToPseudoPod opts lst'
374+ return $ "H<" <> contents <> ">"
375+
376+-- | FIXME - doesnt exist
377+inlineToPseudoPod opts (SmallCaps lst) = inlineListToPseudoPod opts lst
378+
379+inlineToPseudoPod opts (Quoted SingleQuote lst) = do
380+ contents <- inlineListToPseudoPod opts lst
381+ return $ "‘" <> contents <> "’"
382+inlineToPseudoPod opts (Quoted DoubleQuote lst) = do
383+ contents <- inlineListToPseudoPod opts lst
384+ return $ "“" <> contents <> "”"
385+
386+-- | C<>
387+inlineToPseudoPod opts (Code attr str) =
388+ return $ "C<< " <> text (escapeString str) <> " >>"
389+
390+inlineToPseudoPod _ (Str str) = do
391+ st <- get
392+ if stPlain st
393+ then return $ text str
394+ else return $ text $ escapeString str
395+
396+-- | No Math
397+-- inlineToPseudoPod opts (Math _ str) = inlineToPseudoPod opts Inline str
398+
399+inlineToPseudoPod _ (Math InlineMath str) =
400+ return $ "$" <> text str <> "$"
401+inlineToPseudoPod _ (Math DisplayMath str) =
402+ return $ "$$" <> text str <> "$$"
403+
404+inlineToPseudoPod _ (RawInline f str)
405+ | f == "html" || f == "latex" || f == "tex" || f == "PseudoPod" =
406+ return $ text str
407+inlineToPseudoPod _ (RawInline _ _) = return empty
408+inlineToPseudoPod opts (LineBreak) = return $
409+ if writerStrictMarkdown opts
410+ then " " <> cr
411+ else "\\" <> cr
412+inlineToPseudoPod _ Space = return space
413+inlineToPseudoPod opts (Cite (c:cs) lst)
414+ | writerCiteMethod opts == Citeproc = inlineListToPseudoPod opts lst
415+ | citationMode c == AuthorInText = do
416+ suffs <- inlineListToPseudoPod opts $ citationSuffix c
417+ rest <- mapM convertOne cs
418+ let inbr = suffs <+> joincits rest
419+ br = if isEmpty inbr then empty else char '[' <> inbr <> char ']'
420+ return $ text ("@" ++ citationId c) <+> br
421+ | otherwise = do
422+ cits <- mapM convertOne (c:cs)
423+ return $ text "[" <> joincits cits <> text "]"
424+ where
425+ joincits = hcat . intersperse (text "; ") . filter (not . isEmpty)
426+ convertOne Citation { citationId = k
427+ , citationPrefix = pinlines
428+ , citationSuffix = sinlines
429+ , citationMode = m }
430+ = do
431+ pdoc <- inlineListToPseudoPod opts pinlines
432+ sdoc <- inlineListToPseudoPod opts sinlines
433+ let k' = text (modekey m ++ "@" ++ k)
434+ r = case sinlines of
435+ Str (y:_):_ | y `elem` ",;]@" -> k' <> sdoc
436+ _ -> k' <+> sdoc
437+ return $ pdoc <+> r
438+ modekey SuppressAuthor = "-"
439+ modekey _ = ""
440+inlineToPseudoPod _ (Cite _ _) = return $ text ""
441+
442+-- | L<> - DONE
443+inlineToPseudoPod opts (Link txt (src, _)) = do
444+ label <- inlineListToPseudoPod opts txt
445+ return $ "L<" <> label <> "|" <> (text src) <> ">"
446+
447+inlineToPseudoPod opts (Image alternate (source, tit)) = do
448+ let txt = if (null alternate) || (alternate == [Str ""]) ||
449+ (alternate == [Str source]) -- to prevent autolinks
450+ then [Str "image"]
451+ else alternate
452+ linkPart <- inlineToPseudoPod opts (Link txt (source, tit))
453+ return $ "!" <> linkPart
454+
455+-- | N<>
456+inlineToPseudoPod opts (Note blocks) = do
457+-- contents <- blockListToPseudoPod opts blocks
458+ contents <- mapM (blockToPseudoPod opts) blocks
459+ return $ "N<" <> vcat contents <> ">"