@@ -0,0 +1,552 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-
3+Copyright (C) 2014 Albert Krewinkel <tarleb@moltkeplatz.de>
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.Readers.Org
22+ Copyright : Copyright (C) 2014 Albert Krewinkel
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : Albert Krewinkel <tarleb@moltkeplatz.de>
26+
27+Conversion of Org-Mode to 'Pandoc' document.
28+-}
29+module Text.Pandoc.Readers.Org ( readOrg ) where
30+
31+import qualified Text.Pandoc.Builder as B
32+import Text.Pandoc.Builder (Inlines, Blocks, trimInlines, (<>))
33+import Text.Pandoc.Definition
34+import Text.Pandoc.Options
35+import Text.Pandoc.Parsing hiding (orderedListMarker)
36+import Text.Pandoc.Shared (compactify')
37+
38+import Control.Applicative (pure, (<$>), (<$), (<*>), (<*), (*>), (<**>))
39+import Control.Monad (guard, mzero)
40+import Data.Char (toLower)
41+import Data.List (foldl')
42+import Data.Maybe (listToMaybe, fromMaybe)
43+import Data.Monoid (mconcat, mempty, mappend)
44+
45+-- | Parse org-mode string and return a Pandoc document.
46+readOrg :: ReaderOptions -- ^ Reader options
47+ -> String -- ^ String to parse (assuming @'\n'@ line endings)
48+ -> Pandoc
49+readOrg opts s = (readWith parseOrg) def{ stateOptions = opts } (s ++ "\n\n")
50+
51+type OrgParser = Parser [Char] ParserState
52+
53+parseOrg:: OrgParser Pandoc
54+parseOrg = do
55+ blocks' <- B.toList <$> parseBlocks
56+ st <- getState
57+ let meta = stateMeta st
58+ return $ Pandoc meta $ filter (/= Null) blocks'
59+
60+--
61+-- parsing blocks
62+--
63+
64+parseBlocks :: OrgParser Blocks
65+parseBlocks = mconcat <$> manyTill block eof
66+
67+block :: OrgParser Blocks
68+block = choice [ mempty <$ blanklines
69+ , orgBlock
70+ , example
71+ , drawer
72+ , specialLine
73+ , header
74+ , hline
75+ , list
76+ , table
77+ , paraOrPlain
78+ ] <?> "block"
79+
80+--
81+-- Org Blocks (#+BEGIN_... / #+END_...)
82+--
83+
84+orgBlock :: OrgParser Blocks
85+orgBlock = try $ do
86+ (indent, blockType, args) <- blockHeader
87+ blockStr <- rawBlockContent indent blockType
88+ let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ]
89+ case blockType of
90+ "comment" -> return mempty
91+ "src" -> return $ B.codeBlockWith ("", classArgs, []) blockStr
92+ _ -> B.divWith ("", [blockType], [])
93+ <$> (parseFromString parseBlocks blockStr)
94+
95+blockHeader :: OrgParser (Int, String, [String])
96+blockHeader = (,,) <$> blockIndent
97+ <*> blockType
98+ <*> (skipSpaces *> blockArgs)
99+ where blockIndent = length <$> many spaceChar
100+ blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter)
101+ blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline
102+
103+rawBlockContent :: Int -> String -> OrgParser String
104+rawBlockContent indent blockType =
105+ unlines . map commaEscaped <$> manyTill indentedLine blockEnder
106+ where
107+ indentedLine = try $ choice [ blankline *> pure "\n"
108+ , indentWith indent *> anyLine
109+ ]
110+ blockEnder = try $ indentWith indent *> stringAnyCase ("#+end_" <> blockType)
111+
112+-- indent by specified number of spaces (or equiv. tabs)
113+indentWith :: Int -> OrgParser String
114+indentWith num = do
115+ tabStop <- getOption readerTabStop
116+ if (num < tabStop)
117+ then count num (char ' ')
118+ else choice [ try (count num (char ' '))
119+ , try (char '\t' >> count (num - tabStop) (char ' ')) ]
120+
121+translateLang :: String -> String
122+translateLang "sh" = "bash"
123+translateLang cs = cs
124+
125+commaEscaped :: String -> String
126+commaEscaped (',':cs@('*':_)) = cs
127+commaEscaped (',':cs@('#':'+':_)) = cs
128+commaEscaped cs = cs
129+
130+example :: OrgParser Blocks
131+example = try $
132+ B.codeBlockWith ("", ["example"], []) . unlines <$> many1 exampleLine
133+
134+exampleLine :: OrgParser String
135+exampleLine = try $ string ": " *> anyLine
136+
137+-- Drawers for properties or a logbook
138+drawer :: OrgParser Blocks
139+drawer = try $ do
140+ drawerStart
141+ manyTill drawerLine (try drawerEnd)
142+ return mempty
143+
144+drawerStart :: OrgParser String
145+drawerStart = try $
146+ skipSpaces *> drawerName <* skipSpaces <* newline
147+ where drawerName = try $ char ':' *> validDrawerName <* char ':'
148+ validDrawerName = stringAnyCase "PROPERTIES"
149+ <|> stringAnyCase "LOGBOOK"
150+
151+drawerLine :: OrgParser String
152+drawerLine = try $ anyLine
153+
154+drawerEnd :: OrgParser String
155+drawerEnd = try $
156+ skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
157+
158+
159+-- Comments, Options and Metadata
160+specialLine :: OrgParser Blocks
161+specialLine = try $ metaLine <|> commentLine
162+
163+metaLine :: OrgParser Blocks
164+metaLine = try $ metaLineStart *> declarationLine
165+
166+commentLine :: OrgParser Blocks
167+commentLine = try $ commentLineStart *> anyLine *> pure mempty
168+
169+-- The order, in which blocks are tried, makes sure that we're not looking at
170+-- the beginning of a block, so we don't need to check for it
171+metaLineStart :: OrgParser String
172+metaLineStart = try $ mappend <$> many spaceChar <*> string "#+"
173+
174+commentLineStart :: OrgParser String
175+commentLineStart = try $ mappend <$> many spaceChar <*> string "# "
176+
177+declarationLine :: OrgParser Blocks
178+declarationLine = try $ do
179+ meta' <- B.setMeta <$> metaKey <*> metaValue <*> pure nullMeta
180+ updateState $ \st -> st { stateMeta = stateMeta st <> meta' }
181+ return mempty
182+
183+metaValue :: OrgParser MetaValue
184+metaValue = MetaInlines . B.toList . trimInlines <$> restOfLine
185+
186+metaKey :: OrgParser [Char]
187+metaKey = map toLower <$> many1 (noneOf ": \n\r")
188+ <* char ':'
189+ <* skipSpaces
190+
191+-- | Headers
192+header :: OrgParser Blocks
193+header = try $
194+ B.header <$> headerStart
195+ <*> (trimInlines <$> restOfLine)
196+
197+headerStart :: OrgParser Int
198+headerStart = try $
199+ (length <$> many1 (char '*')) <* many1 (char ' ')
200+
201+-- Horizontal Line (five dashes or more)
202+hline :: OrgParser Blocks
203+hline = try $ do
204+ skipSpaces
205+ string "-----"
206+ many (char '-')
207+ skipSpaces
208+ newline
209+ return B.horizontalRule
210+
211+--
212+-- Tables
213+--
214+
215+data OrgTableRow = OrgContentRow [Blocks]
216+ | OrgAlignRow [Alignment]
217+ | OrgHlineRow
218+ deriving (Eq, Show)
219+
220+type OrgTableContent = (Int, [Alignment], [Double], [Blocks], [[Blocks]])
221+
222+table :: OrgParser Blocks
223+table = try $ do
224+ lookAhead tableStart
225+ (_, aligns, widths, heads, lns) <- normalizeTable . tableContent <$> tableRows
226+ return $ B.table "" (zip aligns widths) heads lns
227+
228+tableStart :: OrgParser Char
229+tableStart = try $ skipSpaces *> char '|'
230+
231+tableRows :: OrgParser [OrgTableRow]
232+tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)
233+
234+tableContentRow :: OrgParser OrgTableRow
235+tableContentRow = try $
236+ OrgContentRow <$> (tableStart *> manyTill tableContentCell newline)
237+
238+tableContentCell :: OrgParser Blocks
239+tableContentCell = try $
240+ B.plain . trimInlines . mconcat <$> many1Till inline (try endOfCell)
241+
242+endOfCell :: OrgParser Char
243+-- endOfCell = char '|' <|> newline
244+endOfCell = try $ char '|' <|> lookAhead newline
245+
246+tableAlignRow :: OrgParser OrgTableRow
247+tableAlignRow = try $
248+ OrgAlignRow <$> (tableStart *> manyTill tableAlignCell newline)
249+
250+tableAlignCell :: OrgParser Alignment
251+tableAlignCell =
252+ choice [ try $ emptyCell *> return (AlignDefault)
253+ , try $ skipSpaces
254+ *> char '<'
255+ *> tableAlignFromChar
256+ <* many digit
257+ <* char '>'
258+ <* emptyCell
259+ ] <?> "alignment info"
260+ where emptyCell = try $ skipSpaces *> endOfCell
261+
262+tableAlignFromChar :: OrgParser Alignment
263+tableAlignFromChar = try $ choice [ char 'l' *> return AlignLeft
264+ , char 'c' *> return AlignCenter
265+ , char 'r' *> return AlignRight
266+ ]
267+
268+tableHline :: OrgParser OrgTableRow
269+tableHline = try $
270+ OrgHlineRow <$ (tableStart *> char '-' *> anyLine)
271+
272+tableContent :: [OrgTableRow]
273+ -> OrgTableContent
274+tableContent = foldl' (flip rowToContent) (0, mempty, repeat 0, mempty, mempty)
275+
276+normalizeTable :: OrgTableContent
277+ -> OrgTableContent
278+normalizeTable (cols, aligns, widths, heads, lns) =
279+ let aligns' = fillColumns aligns AlignDefault
280+ widths' = fillColumns widths 0.0
281+ heads' = if heads == mempty
282+ then heads
283+ else fillColumns heads (B.plain mempty)
284+ lns' = map (flip fillColumns (B.plain mempty)) lns
285+ fillColumns base padding = take cols $ base ++ repeat padding
286+ in (cols, aligns', widths', heads', lns')
287+
288+
289+-- One or more horizontal rules after the first content line mark the previous
290+-- line as a header. All other horizontal lines are discarded.
291+rowToContent :: OrgTableRow
292+ -> OrgTableContent
293+ -> OrgTableContent
294+rowToContent OrgHlineRow = maybeBodyToHeader
295+rowToContent (OrgContentRow rs) = setLongestRow rs . appendToBody rs
296+rowToContent (OrgAlignRow as) = setLongestRow as . setAligns as
297+
298+setLongestRow :: [a]
299+ -> OrgTableContent
300+ -> OrgTableContent
301+setLongestRow r (cols, aligns, widths, heads, lns) =
302+ (max cols (length r), aligns, widths, heads, lns)
303+
304+maybeBodyToHeader :: OrgTableContent
305+ -> OrgTableContent
306+maybeBodyToHeader (cols, aligns, widths, [], b:[]) = (cols, aligns, widths, b, [])
307+maybeBodyToHeader content = content
308+
309+appendToBody :: [Blocks]
310+ -> OrgTableContent
311+ -> OrgTableContent
312+appendToBody r (cols, aligns, widths, heads, lns) =
313+ (cols, aligns, widths, heads, lns ++ [r])
314+
315+setAligns :: [Alignment]
316+ -> OrgTableContent
317+ -> OrgTableContent
318+setAligns aligns (cols, _, widths, heads, lns) =
319+ (cols, aligns, widths, heads, lns)
320+
321+-- Paragraphs or Plain text
322+paraOrPlain :: OrgParser Blocks
323+paraOrPlain = try $
324+ trimInlines . mconcat
325+ <$> many1 inline
326+ <**> option B.plain
327+ (try $ newline *> pure B.para)
328+
329+restOfLine :: OrgParser Inlines
330+restOfLine = mconcat <$> manyTill inline newline
331+
332+
333+--
334+-- list blocks
335+--
336+
337+list :: OrgParser Blocks
338+list = choice [ bulletList, orderedList ] <?> "list"
339+
340+bulletList :: OrgParser Blocks
341+bulletList = B.bulletList . compactify' <$> many1 (listItem bulletListStart)
342+
343+orderedList :: OrgParser Blocks
344+orderedList = B.orderedList . compactify' <$> many1 (listItem orderedListStart)
345+
346+genericListStart :: OrgParser String
347+ -> OrgParser Int
348+genericListStart listMarker = try $
349+ (+) <$> (length <$> many spaceChar)
350+ <*> (length <$> listMarker <* many1 spaceChar)
351+
352+-- parses bullet list start and returns its length (excl. following whitespace)
353+bulletListStart :: OrgParser Int
354+bulletListStart = genericListStart bulletListMarker
355+ where bulletListMarker = pure <$> oneOf "*-+"
356+
357+orderedListStart :: OrgParser Int
358+orderedListStart = genericListStart orderedListMarker
359+ -- Ordered list markers allowed in org-mode
360+ where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)")
361+
362+listItem :: OrgParser Int
363+ -> OrgParser Blocks
364+listItem start = try $ do
365+ (markerLength, first) <- try (start >>= rawListItem)
366+ rest <- many (listContinuation markerLength)
367+ parseFromString parseBlocks $ concat (first:rest)
368+
369+-- parse raw text for one list item, excluding start marker and continuations
370+rawListItem :: Int
371+ -> OrgParser (Int, String)
372+rawListItem markerLength = try $ do
373+ firstLine <- anyLine
374+ restLines <- many (listLine markerLength)
375+ return (markerLength, (firstLine ++ "\n" ++ (concat restLines)))
376+
377+-- continuation of a list item - indented and separated by blankline or endline.
378+-- Note: nested lists are parsed as continuations.
379+listContinuation :: Int
380+ -> OrgParser String
381+listContinuation markerLength = try $
382+ mappend <$> many blankline
383+ <*> (concat <$> many1 (listLine markerLength))
384+
385+-- parse a line of a list item
386+listLine :: Int
387+ -> OrgParser String
388+listLine markerLength = try $
389+ indentWith markerLength *> anyLine
390+ <**> pure (++ "\n")
391+
392+
393+--
394+-- inline
395+--
396+
397+inline :: OrgParser Inlines
398+inline = choice inlineParsers <?> "inline"
399+ where inlineParsers = [ whitespace
400+ , link
401+ , str
402+ , endline
403+ , emph
404+ , strong
405+ , strikeout
406+ , underline
407+ , code
408+ , verbatim
409+ , subscript
410+ , superscript
411+ , symbol
412+ ]
413+
414+-- treat these as potentially non-text when parsing inline:
415+specialChars :: [Char]
416+specialChars = "\"$'()*+-./:<=>[\\]^_{|}~"
417+
418+
419+whitespace :: OrgParser Inlines
420+whitespace = B.space <$ skipMany1 spaceChar <?> "whitespace"
421+
422+str :: OrgParser Inlines
423+str = B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
424+ <* updateLastStrPos
425+
426+-- an endline character that can be treated as a space, not a structural break
427+endline :: OrgParser Inlines
428+endline = try $ do
429+ newline
430+ notFollowedBy blankline
431+ notFollowedBy' exampleLine
432+ notFollowedBy' hline
433+ notFollowedBy' tableStart
434+ notFollowedBy' drawerStart
435+ notFollowedBy' headerStart
436+ notFollowedBy' metaLineStart
437+ notFollowedBy' commentLineStart
438+ notFollowedBy' bulletListStart
439+ notFollowedBy' orderedListStart
440+ return B.space
441+
442+link :: OrgParser Inlines
443+link = explicitLink <|> selfLink <?> "link"
444+
445+explicitLink :: OrgParser Inlines
446+explicitLink = try $ do
447+ char '['
448+ src <- enclosedRaw (char '[') (char ']')
449+ title <- enclosedInlines (char '[') (char ']')
450+ char ']'
451+ return $ B.link src "" title
452+
453+selfLink :: OrgParser Inlines
454+selfLink = try $ do
455+ src <- enclosedRaw (string "[[") (string "]]")
456+ return $ B.link src "" (B.str src)
457+
458+emph :: OrgParser Inlines
459+emph = B.emph <$> inlinesEnclosedBy '/'
460+
461+strong :: OrgParser Inlines
462+strong = B.strong <$> inlinesEnclosedBy '*'
463+
464+strikeout :: OrgParser Inlines
465+strikeout = B.strikeout <$> inlinesEnclosedBy '+'
466+
467+-- There is no underline, so we use strong instead.
468+underline :: OrgParser Inlines
469+underline = B.strong <$> inlinesEnclosedBy '_'
470+
471+code :: OrgParser Inlines
472+code = B.code <$> rawEnclosedBy '='
473+
474+verbatim :: OrgParser Inlines
475+verbatim = B.rawInline "" <$> rawEnclosedBy '~'
476+
477+subscript :: OrgParser Inlines
478+subscript = B.subscript <$> (try $ char '_' *> maybeGroupedByBraces)
479+
480+superscript :: OrgParser Inlines
481+superscript = B.superscript <$> (try $ char '^' *> maybeGroupedByBraces)
482+
483+maybeGroupedByBraces :: OrgParser Inlines
484+maybeGroupedByBraces = try $
485+ choice [ try $ enclosedInlines (char '{') (char '}')
486+ , B.str . (:"") <$> anyChar
487+ ]
488+
489+symbol :: OrgParser Inlines
490+symbol = B.str . (: "") <$> oneOf specialChars
491+
492+enclosedInlines :: OrgParser a
493+ -> OrgParser b
494+ -> OrgParser Inlines
495+enclosedInlines start end = try $
496+ trimInlines . mconcat <$> enclosed start end inline
497+
498+-- FIXME: This is a hack
499+inlinesEnclosedBy :: Char
500+ -> OrgParser Inlines
501+inlinesEnclosedBy c = enclosedInlines (atStart (char c) <* endsOnThisOrNextLine c)
502+ (atEnd $ char c)
503+
504+enclosedRaw :: OrgParser a
505+ -> OrgParser b
506+ -> OrgParser String
507+enclosedRaw start end = try $
508+ start *> (onSingleLine <|> spanningTwoLines)
509+ where onSingleLine = try $ many1Till (noneOf "\n\r") end
510+ spanningTwoLines = try $
511+ anyLine >>= \f -> mappend (f <> " ") <$> onSingleLine
512+
513+rawEnclosedBy :: Char
514+ -> OrgParser String
515+rawEnclosedBy c = enclosedRaw (atStart $ char c) (atEnd $ char c)
516+
517+-- succeeds only if we're not right after a str (ie. in middle of word)
518+atStart :: OrgParser a -> OrgParser a
519+atStart p = do
520+ pos <- getPosition
521+ st <- getState
522+ guard $ stateLastStrPos st /= Just pos
523+ p
524+
525+-- | succeeds only if we're at the end of a word
526+atEnd :: OrgParser a -> OrgParser a
527+atEnd p = try $ p <* lookingAtEndOfWord
528+ where lookingAtEndOfWord = lookAhead . oneOf $ postWordChars
529+
530+postWordChars :: [Char]
531+postWordChars = "\t\n\r !\"'),-.:?}"
532+
533+-- FIXME: These functions are hacks and should be replaced
534+endsOnThisOrNextLine :: Char
535+ -> OrgParser ()
536+endsOnThisOrNextLine c = do
537+ inp <- getInput
538+ let doOtherwise = \rest -> endsOnThisLine rest c (const mzero)
539+ endsOnThisLine inp c doOtherwise
540+
541+endsOnThisLine :: [Char]
542+ -> Char
543+ -> ([Char] -> OrgParser ())
544+ -> OrgParser ()
545+endsOnThisLine input c doOnOtherLines = do
546+ case break (`elem` c:"\n") input of
547+ (_,'\n':rest) -> doOnOtherLines rest
548+ (_,_:rest@(n:_)) -> if n `elem` postWordChars
549+ then return ()
550+ else endsOnThisLine rest c doOnOtherLines
551+ _ -> mzero
552+