@@ -0,0 +1,291 @@
1+{-
2+Copyright (C) 2006-2010 Puneeth Chaganti <punchagan@gmail.com>
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.Org
21+ Copyright : Copyright (C) 2006-2010 Puneeth Chaganti
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : Puneeth Chaganti <punchagan@gmail.com>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of 'Pandoc' documents to reStructuredText.
29+
30+reStructuredText: <http://docutils.sourceforge.net/rst.html>
31+-}
32+module Text.Pandoc.Writers.Org ( writeOrg) where
33+import Text.Pandoc.Definition
34+import Text.Pandoc.Shared
35+import Text.Pandoc.Blocks
36+import Text.Pandoc.Templates (renderTemplate)
37+import Data.List ( intersect, intersperse, transpose )
38+import Text.PrettyPrint.HughesPJ hiding ( Str )
39+import Control.Monad.State
40+import Control.Applicative ( (<$>) )
41+
42+data WriterState =
43+ WriterState { stNotes :: [[Block]]
44+ , stLinks :: Bool
45+ , stImages :: Bool
46+ , stHasMath :: Bool
47+ , stOptions :: WriterOptions
48+ }
49+
50+-- | Convert Pandoc to Org.
51+writeOrg :: WriterOptions -> Pandoc -> String
52+writeOrg opts document =
53+ let st = WriterState { stNotes = [], stLinks = False,
54+ stImages = False, stHasMath = False,
55+ stOptions = opts }
56+ in evalState (pandocToOrg document) st
57+
58+-- | Return Org representation of document.
59+pandocToOrg :: Pandoc -> State WriterState String
60+pandocToOrg (Pandoc (Meta tit auth dat) blocks) = do
61+ opts <- liftM stOptions get
62+ title <- titleToOrg tit
63+ authors <- mapM inlineListToOrg auth
64+ date <- inlineListToOrg dat
65+ body <- blockListToOrg blocks
66+ notes <- liftM (reverse . stNotes) get >>= notesToOrg
67+ -- note that the notes may contain refs, so we do them first
68+ hasMath <- liftM stHasMath get
69+ let main = render $ foldl ($+$) empty $ [body, notes]
70+ let context = writerVariables opts ++
71+ [ ("body", main)
72+ , ("title", render title)
73+ , ("date", render date) ] ++
74+ [ ("math", "yes") | hasMath ] ++
75+ [ ("author", render a) | a <- authors ]
76+ if writerStandalone opts
77+ then return $ renderTemplate context $ writerTemplate opts
78+ else return main
79+
80+-- | Return Org representation of notes.
81+notesToOrg :: [[Block]] -> State WriterState Doc
82+notesToOrg notes =
83+ mapM (\(num, note) -> noteToOrg num note) (zip [1..] notes) >>=
84+ return . vcat
85+
86+-- | Return Org representation of a note.
87+noteToOrg :: Int -> [Block] -> State WriterState Doc
88+noteToOrg num note = do
89+ contents <- blockListToOrg note
90+ let marker = text "[" <> text (show num) <> text "] "
91+ return $ marker <> contents
92+
93+-- | Take list of inline elements and return wrapped doc.
94+wrappedOrg :: WriterOptions -> [Inline] -> State WriterState Doc
95+wrappedOrg opts inlines = do
96+ lineBreakDoc <- inlineToOrg LineBreak
97+ chunks <- mapM (wrapIfNeeded opts inlineListToOrg)
98+ (splitBy LineBreak inlines)
99+ return $ vcat $ intersperse lineBreakDoc chunks
100+
101+-- | Escape special characters for Org.
102+escapeString :: String -> String
103+escapeString = escapeStringUsing (backslashEscapes "^_")
104+
105+titleToOrg :: [Inline] -> State WriterState Doc
106+titleToOrg [] = return empty
107+titleToOrg lst = do
108+ contents <- inlineListToOrg lst
109+ let titleName = text "#+TITLE: "
110+ return $ titleName <> contents
111+
112+-- | Convert Pandoc block element to Org.
113+blockToOrg :: Block -- ^ Block element
114+ -> State WriterState Doc
115+blockToOrg Null = return empty
116+blockToOrg (Plain inlines) = do
117+ opts <- get >>= (return . stOptions)
118+ wrappedOrg opts inlines
119+blockToOrg (Para [Image txt (src,tit)]) = do
120+ capt <- inlineListToOrg txt
121+ img <- inlineToOrg (Image txt (src,tit))
122+ return $ text "#+CAPTION: " <> capt <> text "\n" $$ img
123+blockToOrg (Para inlines) = do
124+ opts <- get >>= (return . stOptions)
125+ contents <- wrappedOrg opts inlines
126+ return $ contents <> text "\n"
127+blockToOrg (RawHtml str) =
128+ return $ (text "\n#+BEGIN_HTML\n") $$ (nest 2 $ vcat $ map text (lines str))
129+ $$ (text "\n#+END_HTML\n")
130+blockToOrg HorizontalRule = return $ text "--------------\n"
131+blockToOrg (Header level inlines) = do
132+ contents <- inlineListToOrg inlines
133+ let headerStr = text $ if level > 999 then " " else replicate level '*'
134+ return $ headerStr <> text " " <> contents <> text "\n"
135+blockToOrg (CodeBlock (_,classes,_) str) = do
136+ opts <- stOptions <$> get
137+ let tabstop = writerTabStop opts
138+ let at = classes `intersect` ["asymptote", "C", "clojure", "css", "ditaa",
139+ "dot", "emacs-lisp", "gnuplot", "haskell", "js", "latex",
140+ "ledger", "lisp", "matlab", "mscgen", "ocaml", "octave",
141+ "oz", "perl", "plantuml", "python", "R", "ruby", "sass",
142+ "scheme", "screen", "sh", "sql", "sqlite"]
143+ let (beg, end) = if null at
144+ then ("#+BEGIN_EXAMPLE", "#+END_EXAMPLE")
145+ else ("#+BEGIN_SRC" ++ head at, "#+END_SRC")
146+ return $ text beg $+$ (nest tabstop $ vcat $ map text (lines str))
147+ $+$ text end
148+blockToOrg (BlockQuote blocks) = do
149+ contents <- blockListToOrg blocks
150+ return $ (text "\n#+BEGIN_QUOTE\n") $$ (nest 2 contents)
151+ $$ (text "\n#+END_QUOTE\n")
152+blockToOrg (Table caption' _ _ headers rows) = do
153+ caption'' <- inlineListToOrg caption'
154+ let caption = if null caption'
155+ then empty
156+ else (text "#+CAPTION: " <> caption'')
157+ headers' <- mapM blockListToOrg headers
158+ rawRows <- mapM (mapM blockListToOrg) rows
159+ let numChars = maximum . map (length . render)
160+ -- FIXME: width is not being used.
161+ let widthsInChars =
162+ map ((+2) . numChars) $ transpose (headers' : rawRows)
163+ -- FIXME: Org doesn't allow blocks with height more than 1.
164+ let hpipeBlocks blocks = hcatBlocks [beg, middle, end]
165+ where height = maximum (map heightOfBlock blocks)
166+ sep' = TextBlock 3 height (replicate height " | ")
167+ beg = TextBlock 2 height (replicate height "| ")
168+ end = TextBlock 2 height (replicate height " |")
169+ middle = hcatBlocks $ intersperse sep' blocks
170+ let makeRow = hpipeBlocks . zipWith docToBlock widthsInChars
171+ let head' = makeRow headers'
172+ rows' <- mapM (\row -> do cols <- mapM blockListToOrg row
173+ return $ makeRow cols) rows
174+ let border ch = char '|' <> char ch <>
175+ (hcat $ intersperse (char ch <> char '+' <> char ch) $
176+ map (\l -> text $ replicate l ch) widthsInChars) <>
177+ char ch <> char '|'
178+ let body = vcat $ map blockToDoc rows'
179+ let head'' = if all null headers
180+ then empty
181+ else blockToDoc head' $+$ border '-'
182+ return $ head'' $+$ body $$ caption $$ text ""
183+blockToOrg (BulletList items) = do
184+ contents <- mapM bulletListItemToOrg items
185+ -- ensure that sublists have preceding blank line
186+ return $ text "" $+$ vcat contents <> text "\n"
187+blockToOrg (OrderedList (start, style', delim) items) = do
188+ let markers = take (length items) $ orderedListMarkers
189+ (start, style', delim)
190+ let maxMarkerLength = maximum $ map length markers
191+ let markers' = map (\m -> let s = maxMarkerLength - length m
192+ in m ++ replicate s ' ') markers
193+ contents <- mapM (\(item, num) -> orderedListItemToOrg item num) $
194+ zip markers' items
195+ -- ensure that sublists have preceding blank line
196+ return $ text "" $+$ vcat contents <> text "\n"
197+blockToOrg (DefinitionList items) = do
198+ contents <- mapM definitionListItemToOrg items
199+ return $ (vcat contents) <> text "\n"
200+
201+-- | Convert bullet list item (list of blocks) to Org.
202+bulletListItemToOrg :: [Block] -> State WriterState Doc
203+bulletListItemToOrg items = do
204+ contents <- blockListToOrg items
205+ return $ (text "- ") <> contents
206+
207+-- | Convert ordered list item (a list of blocks) to Org.
208+orderedListItemToOrg :: String -- ^ marker for list item
209+ -> [Block] -- ^ list item (list of blocks)
210+ -> State WriterState Doc
211+orderedListItemToOrg marker items = do
212+ contents <- blockListToOrg items
213+ return $ (text marker <> char ' ') <> contents
214+
215+-- | Convert defintion list item (label, list of blocks) to Org.
216+definitionListItemToOrg :: ([Inline], [[Block]]) -> State WriterState Doc
217+definitionListItemToOrg (label, defs) = do
218+ label' <- inlineListToOrg label
219+ contents <- liftM vcat $ mapM blockListToOrg defs
220+ return $ (text "- ") <> label' <> (text " :: ") <> contents
221+
222+-- | Convert list of Pandoc block elements to Org.
223+blockListToOrg :: [Block] -- ^ List of block elements
224+ -> State WriterState Doc
225+blockListToOrg blocks = mapM blockToOrg blocks >>= return . vcat
226+
227+-- | Convert list of Pandoc inline elements to Org.
228+inlineListToOrg :: [Inline] -> State WriterState Doc
229+inlineListToOrg lst = mapM inlineToOrg lst >>= return . hcat
230+
231+-- | Convert Pandoc inline element to Org.
232+inlineToOrg :: Inline -> State WriterState Doc
233+inlineToOrg (Emph lst) = do
234+ contents <- inlineListToOrg lst
235+ return $ char '/' <> contents <> char '/'
236+inlineToOrg (Strong lst) = do
237+ contents <- inlineListToOrg lst
238+ return $ text "*" <> contents <> text "*"
239+inlineToOrg (Strikeout lst) = do
240+ contents <- inlineListToOrg lst
241+ return $ text "+" <> contents <> char '+'
242+inlineToOrg (Superscript lst) = do
243+ contents <- inlineListToOrg lst
244+ return $ text "^{" <> contents <> text "}"
245+inlineToOrg (Subscript lst) = do
246+ contents <- inlineListToOrg lst
247+ return $ text "_{" <> contents <> text "}"
248+inlineToOrg (SmallCaps lst) = inlineListToOrg lst
249+inlineToOrg (Quoted SingleQuote lst) = do
250+ contents <- inlineListToOrg lst
251+ return $ char '\'' <> contents <> char '\''
252+inlineToOrg (Quoted DoubleQuote lst) = do
253+ contents <- inlineListToOrg lst
254+ return $ char '\"' <> contents <> char '\"'
255+inlineToOrg (Cite _ lst) =
256+ inlineListToOrg lst
257+inlineToOrg EmDash = return $ text "---"
258+inlineToOrg EnDash = return $ text "--"
259+inlineToOrg Apostrophe = return $ char '\''
260+inlineToOrg Ellipses = return $ text "..."
261+inlineToOrg (Code str) = return $ text $ "=" ++ str ++ "="
262+inlineToOrg (Str str) = return $ text $ escapeString str
263+inlineToOrg (Math t str) = do
264+ modify $ \st -> st{ stHasMath = True }
265+ return $ if t == InlineMath
266+ then text $ "$" ++ str ++ "$"
267+ else text $ "$$" ++ str ++ "$$"
268+inlineToOrg (TeX str) = return $ text str
269+inlineToOrg (HtmlInline _) = return empty
270+inlineToOrg (LineBreak) = do
271+ return $ empty -- there's no line break in Org
272+inlineToOrg Space = return $ char ' '
273+inlineToOrg (Link txt (src, _)) = do
274+ case txt of
275+ [Code x] | x == src -> -- autolink
276+ do modify $ \s -> s{ stLinks = True }
277+ return $ text $ "[[" ++ x ++ "]]"
278+ _ -> do contents <- inlineListToOrg txt
279+ modify $ \s -> s{ stLinks = True }
280+ return $ text ("[[" ++ src ++ "][") <> contents <>
281+ (text "]]")
282+inlineToOrg (Image _ (source', _)) = do
283+ let source = unescapeURI source'
284+ modify $ \s -> s{ stImages = True }
285+ return $ text $ "[[" ++ source ++ "]]"
286+inlineToOrg (Note contents) = do
287+ -- add to notes in state
288+ notes <- get >>= (return . stNotes)
289+ modify $ \st -> st { stNotes = contents:notes }
290+ let ref = show $ (length notes) + 1
291+ return $ text " [" <> text ref <> text "]"