@@ -0,0 +1,448 @@
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 $ text("=encoding utf8\n\n") <> 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>"), ('<', "E<lt>"), ('|', "E<verbar>"), ('/', "E<sol>")]
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 <> blankline
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+
179+blockToPseudoPod _ (RawBlock f str)
180+ | f == "html" || f == "latex" || f == "tex" || f == "PseudoPod" = do
181+ st <- get
182+ if stPlain st
183+ then return empty
184+ else return $ text str <> text "\n"
185+blockToPseudoPod _ (RawBlock _ _) = return empty
186+
187+-- | No horizontal rules, leave a space
188+blockToPseudoPod _ HorizontalRule =
189+ return $ blankline <> blankline <> blankline
190+
191+-- | =headN <content> - DONE
192+blockToPseudoPod opts (Header level inlines) = do
193+ contents <- inlineListToPseudoPod opts inlines
194+ return $ "=head" <> text (show level) <> " " <> contents <> blankline
195+
196+{-
197+blockToPseudoPod opts (CodeBlock (_,classes,_) str)
198+ | "haskell" `elem` classes && "literate" `elem` classes &&
199+ writerLiterateHaskell opts =
200+ return $ prefixed "> " (text str) <> blankline
201+-}
202+
203+-- | indent 3 spaces - DONE
204+blockToPseudoPod _ (CodeBlock _ str) = return $
205+ nest 3 (text str) <> blankline
206+
207+{-
208+ if writerStrictMarkdown opts || attribs == nullAttr
209+ then nest (writerTabStop opts) (text str) <> blankline
210+ else -- use delimited code block
211+ flush (tildes <> space <> attrs <> cr <> text str <>
212+ cr <> tildes) <> blankline
213+ where tildes = text "~~~~"
214+ attrs = attrsToPseudoPod attribs
215+-}
216+
217+-- | =begin blockquote ?
218+blockToPseudoPod opts (BlockQuote blocks) = do
219+ contents <- blockListToPseudoPod opts blocks
220+ return $ "=begin blockquote" <> blankline <> contents <> blankline <> "=end blockquote" <> blankline
221+
222+-- | =begin table <caption> / =headrow / =row / =cell / =bodyrows / =row / =cell / =end table
223+blockToPseudoPod opts (Table caption _ _ headers rows) = do
224+ caption' <- inlineListToPseudoPod opts caption
225+ headers' <- mapM (blockListToPseudoPod opts) headers
226+
227+ rawRows <- mapM (mapM (blockListToPseudoPod opts)) rows
228+ let makeRow = hcat . intersperse (text("\n=cell "))
229+ let makeRowBlock = hcat . intersperse (text("\n=row\n\n=cell "))
230+
231+ let rows' = map makeRow rawRows
232+ let rows'' = makeRowBlock rows'
233+ let rows''' = "=row" <> blankline <> "=cell " <> rows''
234+
235+ let head' = makeRow headers'
236+ let head'' = "=row" <> blankline <> "=cell " <> head'
237+
238+ return $ "=begin table " <> caption' <> blankline <> "=headrow" <> blankline <> head'' <> blankline <> "=bodyrows" <> blankline <> rows''' <> blankline <> "=end table" <> blankline
239+
240+-- | =over / =item * / =back
241+blockToPseudoPod opts (BulletList items) = do
242+ contents <- mapM (bulletListItemToPseudoPod opts) items
243+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
244+
245+
246+-- | =over / =item N. / =back
247+blockToPseudoPod opts (OrderedList attribs items) = do
248+ let markers = orderedListMarkers attribs
249+ let markers' = map (\m -> if length m < 3
250+ then m ++ replicate (3 - length m) ' '
251+ else m) markers
252+ contents <- mapM (\(item, num) -> orderedListItemToPseudoPod opts item num) $
253+ zip markers' items
254+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
255+-- return $ cat contents <> blankline
256+
257+blockToPseudoPod opts (DefinitionList items) = do
258+ contents <- mapM (definitionListItemToPseudoPod opts) items
259+ return $ "=over" <> blankline <> cat contents <> blankline <> "=back" <> blankline
260+
261+-- | bullet list -> =item *
262+bulletListItemToPseudoPod :: WriterOptions -> [Block] -> State WriterState Doc
263+bulletListItemToPseudoPod opts items = do
264+ contents <- blockListToPseudoPod opts items
265+ return $ "=item *" <> blankline <> contents <> blankline
266+
267+-- | Convert ordered list item (a list of blocks) to PseudoPod.
268+orderedListItemToPseudoPod :: WriterOptions -- ^ options
269+ -> String -- ^ list item marker
270+ -> [Block] -- ^ list item (list of blocks)
271+ -> State WriterState Doc
272+orderedListItemToPseudoPod opts marker items = do
273+ contents <- blockListToPseudoPod opts items
274+ return $ "=item " <> (text marker) <> blankline <> contents <> blankline
275+
276+{-
277+ let sps = case length marker - writerTabStop opts of
278+ n | n > 0 -> text $ replicate n ' '
279+ _ -> text " "
280+ let start = text marker <> sps
281+ return $ hang (writerTabStop opts) start $ contents <> cr
282+-}
283+
284+{-
285+-- | Convert definition list item (label, list of blocks) to markdown.
286+definitionListItemToPseudoPod :: WriterOptions
287+ -> ([Inline],[[Block]])
288+ -> State WriterState Doc
289+definitionListItemToPseudoPod opts (label, defs) = do
290+ labelText <- inlineListToPseudoPod opts label
291+ let tabStop = writerTabStop opts
292+ st <- get
293+ let leader = if stPlain st then " " else " ~"
294+ let sps = case writerTabStop opts - 3 of
295+ n | n > 0 -> text $ replicate n ' '
296+ _ -> text " "
297+ defs' <- mapM (mapM (blockToPseudoPod opts)) defs
298+ let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs'
299+ return $ labelText <> cr <> contents <> cr
300+-}
301+
302+-- | Convert definition list item (label, list of blocks) to PseudoPod.
303+-- | =over / =item FOO / para / =back
304+definitionListItemToPseudoPod :: WriterOptions
305+ -> ([Inline],[[Block]])
306+ -> State WriterState Doc
307+definitionListItemToPseudoPod opts (label, defs) = do
308+ labelText <- inlineListToPseudoPod opts label
309+ -- each call to definitonListItemToPseudoPod is one label, which can have multiple defintions. (Each definition is a [Block].)
310+
311+ defs' <- mapM (blockListToPseudoPod opts) defs
312+-- let contents = vcat $ map (\d -> "=item") $ vcat d <> cr) defs'
313+ return $ "=item " <> labelText <> blankline <> vcat defs' <> blankline
314+
315+
316+-- | Convert list of Pandoc block elements to PseudoPod.
317+blockListToPseudoPod :: WriterOptions -- ^ Options
318+ -> [Block] -- ^ List of block elements
319+ -> State WriterState Doc
320+blockListToPseudoPod opts blocks =
321+ mapM (blockToPseudoPod opts) (blocks) >>= return . cat
322+
323+-- | Convert list of Pandoc inline elements to PseudoPod.
324+inlineListToPseudoPod :: WriterOptions -> [Inline] -> State WriterState Doc
325+inlineListToPseudoPod opts lst =
326+ mapM (inlineToPseudoPod opts) lst >>= return . cat
327+
328+escapeSpaces :: Inline -> Inline
329+escapeSpaces (Str s) = Str $ substitute " " "\\ " s
330+escapeSpaces Space = Str "\\ "
331+escapeSpaces x = x
332+
333+-- | Convert Pandoc inline element to PseudoPod.
334+inlineToPseudoPod :: WriterOptions -> Inline -> State WriterState Doc
335+
336+-- | I< > - DONE
337+inlineToPseudoPod opts (Emph lst) = do
338+ contents <- inlineListToPseudoPod opts lst
339+ return $ "I<" <> contents <> ">"
340+
341+-- | B< > - DONE
342+inlineToPseudoPod opts (Strong lst) = do
343+ contents <- inlineListToPseudoPod opts lst
344+ return $ "B<" <> contents <> ">"
345+
346+inlineToPseudoPod opts (Strikeout lst) = inlineListToPseudoPod opts lst
347+{-
348+inlineToPseudoPod opts (Strikeout lst) = do
349+ contents <- inlineListToPseudoPod opts lst
350+ return $ "~~" <> contents <> "~~"
351+-}
352+
353+-- | G<>
354+inlineToPseudoPod opts (Superscript lst) = do
355+ let lst' = bottomUp escapeSpaces lst
356+ contents <- inlineListToPseudoPod opts lst'
357+ return $ "G<" <> contents <> ">"
358+
359+-- | H<>
360+inlineToPseudoPod opts (Subscript lst) = do
361+ let lst' = bottomUp escapeSpaces lst
362+ contents <- inlineListToPseudoPod opts lst'
363+ return $ "H<" <> contents <> ">"
364+
365+-- | FIXME - doesnt exist
366+inlineToPseudoPod opts (SmallCaps lst) = inlineListToPseudoPod opts lst
367+
368+inlineToPseudoPod opts (Quoted SingleQuote lst) = do
369+ contents <- inlineListToPseudoPod opts lst
370+ return $ "‘" <> contents <> "’"
371+inlineToPseudoPod opts (Quoted DoubleQuote lst) = do
372+ contents <- inlineListToPseudoPod opts lst
373+ return $ "“" <> contents <> "”"
374+
375+-- | C<>
376+inlineToPseudoPod opts (Code attr str) =
377+ return $ "C<< " <> text (escapeString str) <> " >>"
378+
379+inlineToPseudoPod _ (Str str) = do
380+ st <- get
381+ if stPlain st
382+ then return $ text str
383+ else return $ text $ escapeString str
384+
385+-- | No Math
386+-- inlineToPseudoPod opts (Math _ str) = inlineToPseudoPod opts Inline str
387+
388+inlineToPseudoPod _ (Math InlineMath str) =
389+ return $ "$" <> text str <> "$"
390+inlineToPseudoPod _ (Math DisplayMath str) =
391+ return $ "$$" <> text str <> "$$"
392+
393+inlineToPseudoPod _ (RawInline f str)
394+ | f == "html" || f == "latex" || f == "tex" || f == "PseudoPod" =
395+ return $ text str
396+inlineToPseudoPod _ (RawInline _ _) = return empty
397+inlineToPseudoPod opts (LineBreak) = return $
398+ if writerStrictMarkdown opts
399+ then " " <> cr
400+ else "\\" <> cr
401+inlineToPseudoPod _ Space = return space
402+inlineToPseudoPod opts (Cite (c:cs) lst)
403+ | writerCiteMethod opts == Citeproc = inlineListToPseudoPod opts lst
404+ | citationMode c == AuthorInText = do
405+ suffs <- inlineListToPseudoPod opts $ citationSuffix c
406+ rest <- mapM convertOne cs
407+ let inbr = suffs <+> joincits rest
408+ br = if isEmpty inbr then empty else char '[' <> inbr <> char ']'
409+ return $ text ("@" ++ citationId c) <+> br
410+ | otherwise = do
411+ cits <- mapM convertOne (c:cs)
412+ return $ text "[" <> joincits cits <> text "]"
413+ where
414+ joincits = hcat . intersperse (text "; ") . filter (not . isEmpty)
415+ convertOne Citation { citationId = k
416+ , citationPrefix = pinlines
417+ , citationSuffix = sinlines
418+ , citationMode = m }
419+ = do
420+ pdoc <- inlineListToPseudoPod opts pinlines
421+ sdoc <- inlineListToPseudoPod opts sinlines
422+ let k' = text (modekey m ++ "@" ++ k)
423+ r = case sinlines of
424+ Str (y:_):_ | y `elem` ",;]@" -> k' <> sdoc
425+ _ -> k' <+> sdoc
426+ return $ pdoc <+> r
427+ modekey SuppressAuthor = "-"
428+ modekey _ = ""
429+inlineToPseudoPod _ (Cite _ _) = return $ text ""
430+
431+-- | L<> - DONE
432+inlineToPseudoPod opts (Link txt (src, _)) = do
433+ label <- inlineListToPseudoPod opts txt
434+ return $ "L<" <> label <> "|" <> (text src) <> ">"
435+
436+inlineToPseudoPod opts (Image alternate (source, tit)) = do
437+ let txt = if (null alternate) || (alternate == [Str ""]) ||
438+ (alternate == [Str source]) -- to prevent autolinks
439+ then [Str "image"]
440+ else alternate
441+ linkPart <- inlineToPseudoPod opts (Link txt (source, tit))
442+ return $ "!" <> linkPart
443+
444+-- | N<>
445+inlineToPseudoPod opts (Note blocks) = do
446+-- contents <- blockListToPseudoPod opts blocks
447+ contents <- mapM (blockToPseudoPod opts) blocks
448+ return $ "N<" <> cat contents <> ">"