@@ -0,0 +1,552 @@
1+{-# LANGUAGE OverloadedStrings #-}
3+Copyright (C) 2014 Albert Krewinkel <tarleb@moltkeplatz.de>
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.
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.
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
21+ Module : Text.Pandoc.Readers.Org
22+ Copyright : Copyright (C) 2014 Albert Krewinkel
23+ License : GNU GPL, version 2 or above
25+ Maintainer : Albert Krewinkel <tarleb@moltkeplatz.de>
27+Conversion of Org-Mode to 'Pandoc' document.
29+module Text.Pandoc.Readers.Org ( readOrg ) where
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')
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)
45+-- | Parse org-mode string and return a Pandoc document.
46+readOrg :: ReaderOptions -- ^ Reader options
47+ -> String -- ^ String to parse (assuming @'\n'@ line endings)
49+readOrg opts s = (readWith parseOrg) def{ stateOptions = opts } (s ++ "\n\n")
51+type OrgParser = Parser [Char] ParserState
53+parseOrg:: OrgParser Pandoc
55+ blocks' <- B.toList <$> parseBlocks
57+ let meta = stateMeta st
58+ return $ Pandoc meta $ filter (/= Null) blocks'
64+parseBlocks :: OrgParser Blocks
65+parseBlocks = mconcat <$> manyTill block eof
67+block :: OrgParser Blocks
68+block = choice [ mempty <$ blanklines
81+-- Org Blocks (#+BEGIN_... / #+END_...)
84+orgBlock :: OrgParser Blocks
86+ (indent, blockType, args) <- blockHeader
87+ blockStr <- rawBlockContent indent blockType
88+ let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ]
90+ "comment" -> return mempty
91+ "src" -> return $ B.codeBlockWith ("", classArgs, []) blockStr
92+ _ -> B.divWith ("", [blockType], [])
93+ <$> (parseFromString parseBlocks blockStr)
95+blockHeader :: OrgParser (Int, String, [String])
96+blockHeader = (,,) <$> blockIndent
98+ <*> (skipSpaces *> blockArgs)
99+ where blockIndent = length <$> many spaceChar
100+ blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter)
101+ blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline
103+rawBlockContent :: Int -> String -> OrgParser String
104+rawBlockContent indent blockType =
105+ unlines . map commaEscaped <$> manyTill indentedLine blockEnder
107+ indentedLine = try $ choice [ blankline *> pure "\n"
108+ , indentWith indent *> anyLine
110+ blockEnder = try $ indentWith indent *> stringAnyCase ("#+end_" <> blockType)
112+-- indent by specified number of spaces (or equiv. tabs)
113+indentWith :: Int -> OrgParser String
115+ tabStop <- getOption readerTabStop
117+ then count num (char ' ')
118+ else choice [ try (count num (char ' '))
119+ , try (char '\t' >> count (num - tabStop) (char ' ')) ]
121+translateLang :: String -> String
122+translateLang "sh" = "bash"
123+translateLang cs = cs
125+commaEscaped :: String -> String
126+commaEscaped (',':cs@('*':_)) = cs
127+commaEscaped (',':cs@('#':'+':_)) = cs
130+example :: OrgParser Blocks
132+ B.codeBlockWith ("", ["example"], []) . unlines <$> many1 exampleLine
134+exampleLine :: OrgParser String
135+exampleLine = try $ string ": " *> anyLine
137+-- Drawers for properties or a logbook
138+drawer :: OrgParser Blocks
141+ manyTill drawerLine (try drawerEnd)
144+drawerStart :: OrgParser String
146+ skipSpaces *> drawerName <* skipSpaces <* newline
147+ where drawerName = try $ char ':' *> validDrawerName <* char ':'
148+ validDrawerName = stringAnyCase "PROPERTIES"
149+ <|> stringAnyCase "LOGBOOK"
151+drawerLine :: OrgParser String
152+drawerLine = try $ anyLine
154+drawerEnd :: OrgParser String
156+ skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
159+-- Comments, Options and Metadata
160+specialLine :: OrgParser Blocks
161+specialLine = try $ metaLine <|> commentLine
163+metaLine :: OrgParser Blocks
164+metaLine = try $ metaLineStart *> declarationLine
166+commentLine :: OrgParser Blocks
167+commentLine = try $ commentLineStart *> anyLine *> pure mempty
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 "#+"
174+commentLineStart :: OrgParser String
175+commentLineStart = try $ mappend <$> many spaceChar <*> string "# "
177+declarationLine :: OrgParser Blocks
178+declarationLine = try $ do
179+ meta' <- B.setMeta <$> metaKey <*> metaValue <*> pure nullMeta
180+ updateState $ \st -> st { stateMeta = stateMeta st <> meta' }
183+metaValue :: OrgParser MetaValue
184+metaValue = MetaInlines . B.toList . trimInlines <$> restOfLine
186+metaKey :: OrgParser [Char]
187+metaKey = map toLower <$> many1 (noneOf ": \n\r")
192+header :: OrgParser Blocks
194+ B.header <$> headerStart
195+ <*> (trimInlines <$> restOfLine)
197+headerStart :: OrgParser Int
199+ (length <$> many1 (char '*')) <* many1 (char ' ')
201+-- Horizontal Line (five dashes or more)
202+hline :: OrgParser Blocks
209+ return B.horizontalRule
215+data OrgTableRow = OrgContentRow [Blocks]
216+ | OrgAlignRow [Alignment]
220+type OrgTableContent = (Int, [Alignment], [Double], [Blocks], [[Blocks]])
222+table :: OrgParser Blocks
224+ lookAhead tableStart
225+ (_, aligns, widths, heads, lns) <- normalizeTable . tableContent <$> tableRows
226+ return $ B.table "" (zip aligns widths) heads lns
228+tableStart :: OrgParser Char
229+tableStart = try $ skipSpaces *> char '|'
231+tableRows :: OrgParser [OrgTableRow]
232+tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)
234+tableContentRow :: OrgParser OrgTableRow
235+tableContentRow = try $
236+ OrgContentRow <$> (tableStart *> manyTill tableContentCell newline)
238+tableContentCell :: OrgParser Blocks
239+tableContentCell = try $
240+ B.plain . trimInlines . mconcat <$> many1Till inline (try endOfCell)
242+endOfCell :: OrgParser Char
243+-- endOfCell = char '|' <|> newline
244+endOfCell = try $ char '|' <|> lookAhead newline
246+tableAlignRow :: OrgParser OrgTableRow
247+tableAlignRow = try $
248+ OrgAlignRow <$> (tableStart *> manyTill tableAlignCell newline)
250+tableAlignCell :: OrgParser Alignment
252+ choice [ try $ emptyCell *> return (AlignDefault)
255+ *> tableAlignFromChar
259+ ] <?> "alignment info"
260+ where emptyCell = try $ skipSpaces *> endOfCell
262+tableAlignFromChar :: OrgParser Alignment
263+tableAlignFromChar = try $ choice [ char 'l' *> return AlignLeft
264+ , char 'c' *> return AlignCenter
265+ , char 'r' *> return AlignRight
268+tableHline :: OrgParser OrgTableRow
270+ OrgHlineRow <$ (tableStart *> char '-' *> anyLine)
272+tableContent :: [OrgTableRow]
274+tableContent = foldl' (flip rowToContent) (0, mempty, repeat 0, mempty, mempty)
276+normalizeTable :: 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
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')
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
294+rowToContent OrgHlineRow = maybeBodyToHeader
295+rowToContent (OrgContentRow rs) = setLongestRow rs . appendToBody rs
296+rowToContent (OrgAlignRow as) = setLongestRow as . setAligns as
301+setLongestRow r (cols, aligns, widths, heads, lns) =
302+ (max cols (length r), aligns, widths, heads, lns)
304+maybeBodyToHeader :: OrgTableContent
306+maybeBodyToHeader (cols, aligns, widths, [], b:[]) = (cols, aligns, widths, b, [])
307+maybeBodyToHeader content = content
309+appendToBody :: [Blocks]
312+appendToBody r (cols, aligns, widths, heads, lns) =
313+ (cols, aligns, widths, heads, lns ++ [r])
315+setAligns :: [Alignment]
318+setAligns aligns (cols, _, widths, heads, lns) =
319+ (cols, aligns, widths, heads, lns)
321+-- Paragraphs or Plain text
322+paraOrPlain :: OrgParser Blocks
324+ trimInlines . mconcat
327+ (try $ newline *> pure B.para)
329+restOfLine :: OrgParser Inlines
330+restOfLine = mconcat <$> manyTill inline newline
337+list :: OrgParser Blocks
338+list = choice [ bulletList, orderedList ] <?> "list"
340+bulletList :: OrgParser Blocks
341+bulletList = B.bulletList . compactify' <$> many1 (listItem bulletListStart)
343+orderedList :: OrgParser Blocks
344+orderedList = B.orderedList . compactify' <$> many1 (listItem orderedListStart)
346+genericListStart :: OrgParser String
348+genericListStart listMarker = try $
349+ (+) <$> (length <$> many spaceChar)
350+ <*> (length <$> listMarker <* many1 spaceChar)
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 "*-+"
357+orderedListStart :: OrgParser Int
358+orderedListStart = genericListStart orderedListMarker
359+ -- Ordered list markers allowed in org-mode
360+ where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)")
362+listItem :: OrgParser Int
364+listItem start = try $ do
365+ (markerLength, first) <- try (start >>= rawListItem)
366+ rest <- many (listContinuation markerLength)
367+ parseFromString parseBlocks $ concat (first:rest)
369+-- parse raw text for one list item, excluding start marker and continuations
371+ -> OrgParser (Int, String)
372+rawListItem markerLength = try $ do
373+ firstLine <- anyLine
374+ restLines <- many (listLine markerLength)
375+ return (markerLength, (firstLine ++ "\n" ++ (concat restLines)))
377+-- continuation of a list item - indented and separated by blankline or endline.
378+-- Note: nested lists are parsed as continuations.
379+listContinuation :: Int
381+listContinuation markerLength = try $
382+ mappend <$> many blankline
383+ <*> (concat <$> many1 (listLine markerLength))
385+-- parse a line of a list item
388+listLine markerLength = try $
389+ indentWith markerLength *> anyLine
397+inline :: OrgParser Inlines
398+inline = choice inlineParsers <?> "inline"
399+ where inlineParsers = [ whitespace
414+-- treat these as potentially non-text when parsing inline:
415+specialChars :: [Char]
416+specialChars = "\"$'()*+-./:<=>[\\]^_{|}~"
419+whitespace :: OrgParser Inlines
420+whitespace = B.space <$ skipMany1 spaceChar <?> "whitespace"
422+str :: OrgParser Inlines
423+str = B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
426+-- an endline character that can be treated as a space, not a structural break
427+endline :: OrgParser Inlines
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
442+link :: OrgParser Inlines
443+link = explicitLink <|> selfLink <?> "link"
445+explicitLink :: OrgParser Inlines
446+explicitLink = try $ do
448+ src <- enclosedRaw (char '[') (char ']')
449+ title <- enclosedInlines (char '[') (char ']')
451+ return $ B.link src "" title
453+selfLink :: OrgParser Inlines
455+ src <- enclosedRaw (string "[[") (string "]]")
456+ return $ B.link src "" (B.str src)
458+emph :: OrgParser Inlines
459+emph = B.emph <$> inlinesEnclosedBy '/'
461+strong :: OrgParser Inlines
462+strong = B.strong <$> inlinesEnclosedBy '*'
464+strikeout :: OrgParser Inlines
465+strikeout = B.strikeout <$> inlinesEnclosedBy '+'
467+-- There is no underline, so we use strong instead.
468+underline :: OrgParser Inlines
469+underline = B.strong <$> inlinesEnclosedBy '_'
471+code :: OrgParser Inlines
472+code = B.code <$> rawEnclosedBy '='
474+verbatim :: OrgParser Inlines
475+verbatim = B.rawInline "" <$> rawEnclosedBy '~'
477+subscript :: OrgParser Inlines
478+subscript = B.subscript <$> (try $ char '_' *> maybeGroupedByBraces)
480+superscript :: OrgParser Inlines
481+superscript = B.superscript <$> (try $ char '^' *> maybeGroupedByBraces)
483+maybeGroupedByBraces :: OrgParser Inlines
484+maybeGroupedByBraces = try $
485+ choice [ try $ enclosedInlines (char '{') (char '}')
486+ , B.str . (:"") <$> anyChar
489+symbol :: OrgParser Inlines
490+symbol = B.str . (: "") <$> oneOf specialChars
492+enclosedInlines :: OrgParser a
494+ -> OrgParser Inlines
495+enclosedInlines start end = try $
496+ trimInlines . mconcat <$> enclosed start end inline
498+-- FIXME: This is a hack
499+inlinesEnclosedBy :: Char
500+ -> OrgParser Inlines
501+inlinesEnclosedBy c = enclosedInlines (atStart (char c) <* endsOnThisOrNextLine c)
504+enclosedRaw :: OrgParser a
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
513+rawEnclosedBy :: Char
515+rawEnclosedBy c = enclosedRaw (atStart $ char c) (atEnd $ char c)
517+-- succeeds only if we're not right after a str (ie. in middle of word)
518+atStart :: OrgParser a -> OrgParser a
522+ guard $ stateLastStrPos st /= Just pos
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
530+postWordChars :: [Char]
531+postWordChars = "\t\n\r !\"'),-.:?}"
533+-- FIXME: These functions are hacks and should be replaced
534+endsOnThisOrNextLine :: Char
536+endsOnThisOrNextLine c = do
538+ let doOtherwise = \rest -> endsOnThisLine rest c (const mzero)
539+ endsOnThisLine inp c doOtherwise
541+endsOnThisLine :: [Char]
543+ -> ([Char] -> 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
550+ else endsOnThisLine rest c doOnOtherLines