@@ -1,5 +1,3 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE OverloadedStrings #-}
31{-
42Copyright (C) 2014-2016 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
53
@@ -29,32 +27,15 @@ Conversion of org-mode formatted plain text to 'Pandoc' document.
2927-}
3028module Text.Pandoc.Readers.Org ( readOrg ) where
3129
32−import qualified Text.Pandoc.Builder as B
33−import Text.Pandoc.Builder ( Inlines, Blocks )
30+import Text.Pandoc.Readers.Org.Blocks ( blockList, meta )
31+import Text.Pandoc.Readers.Org.Parsing ( OrgParser, readWithM )
32+import Text.Pandoc.Readers.Org.ParserState ( OrgParserState (..) )
33+
3434import Text.Pandoc.Definition
35−import Text.Pandoc.Compat.Monoid ((<>))
3635import Text.Pandoc.Error
3736import Text.Pandoc.Options
38−import qualified Text.Pandoc.Parsing as P
39−import Text.Pandoc.Parsing hiding ( F, unF, askF, asksF, runF
40− , anyLine, blanklines, newline
41− , orderedListMarker
42− , parseFromString
43− )
44−import Text.Pandoc.Readers.LaTeX (inlineCommand, rawLaTeXInline)
45−import Text.Pandoc.Readers.Org.ParserState
46−import Text.Pandoc.Shared (compactify', compactify'DL)
47−import Text.TeXMath (readTeX, writePandoc, DisplayType(..))
48−import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap
4937
50−import Control.Arrow (first)
51−import Control.Monad (foldM, guard, mplus, mzero, when)
52−import Control.Monad.Reader ( Reader, runReader )
53−import Data.Char (isAlphaNum, isSpace, toLower, toUpper)
54−import Data.List ( foldl', intersperse, isPrefixOf, isSuffixOf )
55−import qualified Data.Map as M
56−import Data.Maybe ( fromMaybe, isNothing )
57−import Network.HTTP (urlEncode)
38+import Control.Monad.Reader ( runReader )
5839
5940
6041-- | Parse org-mode string and return a Pandoc document.
@@ -63,165 +44,17 @@ readOrg :: ReaderOptions -- ^ Reader options
6344 -> Either PandocError Pandoc
6445readOrg opts s = flip runReader def $ readWithM parseOrg def{ orgStateOptions = opts } (s ++ "\n\n")
6546
66−-- | The parser used to read org files.
67−type OrgParser = ParserT [Char] OrgParserState (Reader OrgParserLocal)
68−
69−--
70−-- Functions acting on the parser state
71−--
72−recordAnchorId :: String -> OrgParser ()
73−recordAnchorId i = updateState $ \s ->
74− s{ orgStateAnchorIds = i : (orgStateAnchorIds s) }
75−
76−updateLastForbiddenCharPos :: OrgParser ()
77−updateLastForbiddenCharPos = getPosition >>= \p ->
78− updateState $ \s -> s{ orgStateLastForbiddenCharPos = Just p}
79−
80−updateLastPreCharPos :: OrgParser ()
81−updateLastPreCharPos = getPosition >>= \p ->
82− updateState $ \s -> s{ orgStateLastPreCharPos = Just p}
83−
84−pushToInlineCharStack :: Char -> OrgParser ()
85−pushToInlineCharStack c = updateState $ \s ->
86− s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s }
87−
88−popInlineCharStack :: OrgParser ()
89−popInlineCharStack = updateState $ \s ->
90− s{ orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ s }
91−
92−surroundingEmphasisChar :: OrgParser [Char]
93−surroundingEmphasisChar =
94− take 1 . drop 1 . orgStateEmphasisCharStack <$> getState
95−
96−startEmphasisNewlinesCounting :: Int -> OrgParser ()
97−startEmphasisNewlinesCounting maxNewlines = updateState $ \s ->
98− s{ orgStateEmphasisNewlines = Just maxNewlines }
99−
100−decEmphasisNewlinesCount :: OrgParser ()
101−decEmphasisNewlinesCount = updateState $ \s ->
102− s{ orgStateEmphasisNewlines = (\n -> n - 1) <$> orgStateEmphasisNewlines s }
103−
104−newlinesCountWithinLimits :: OrgParser Bool
105−newlinesCountWithinLimits = do
106− st <- getState
107− return $ ((< 0) <$> orgStateEmphasisNewlines st) /= Just True
108−
109−resetEmphasisNewlines :: OrgParser ()
110−resetEmphasisNewlines = updateState $ \s ->
111− s{ orgStateEmphasisNewlines = Nothing }
112−
113−addLinkFormat :: String
114− -> (String -> String)
115− -> OrgParser ()
116−addLinkFormat key formatter = updateState $ \s ->
117− let fs = orgStateLinkFormatters s
118− in s{ orgStateLinkFormatters = M.insert key formatter fs }
119−
120−addToNotesTable :: OrgNoteRecord -> OrgParser ()
121−addToNotesTable note = do
122− oldnotes <- orgStateNotes' <$> getState
123− updateState $ \s -> s{ orgStateNotes' = note:oldnotes }
124−
125−--
126−-- Export Settings
127−--
128−exportSetting :: OrgParser ()
129−exportSetting = choice
130− [ booleanSetting "^" setExportSubSuperscripts
131− , ignoredSetting "'"
132− , ignoredSetting "*"
133− , ignoredSetting "-"
134− , ignoredSetting ":"
135− , ignoredSetting "<"
136− , ignoredSetting "\\n"
137− , ignoredSetting "arch"
138− , ignoredSetting "author"
139− , ignoredSetting "c"
140− , ignoredSetting "creator"
141− , complementableListSetting "d" setExportDrawers
142− , ignoredSetting "date"
143− , ignoredSetting "e"
144− , ignoredSetting "email"
145− , ignoredSetting "f"
146− , ignoredSetting "H"
147− , ignoredSetting "inline"
148− , ignoredSetting "num"
149− , ignoredSetting "p"
150− , ignoredSetting "pri"
151− , ignoredSetting "prop"
152− , ignoredSetting "stat"
153− , ignoredSetting "tags"
154− , ignoredSetting "tasks"
155− , ignoredSetting "tex"
156− , ignoredSetting "timestamp"
157− , ignoredSetting "title"
158− , ignoredSetting "toc"
159− , ignoredSetting "todo"
160− , ignoredSetting "|"
161− ] <?> "export setting"
162−
163−booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()
164−booleanSetting settingIdentifier setter = try $ do
165− string settingIdentifier
166− char ':'
167− value <- elispBoolean
168− updateState $ modifyExportSettings setter value
169−
170−-- | Read an elisp boolean. Only NIL is treated as false, non-NIL values are
171−-- interpreted as true.
172−elispBoolean :: OrgParser Bool
173−elispBoolean = try $ do
174− value <- many1 nonspaceChar
175− return $ case map toLower value of
176− "nil" -> False
177− "{}" -> False
178− "()" -> False
179− _ -> True
180−
181−-- | A list or a complement list (i.e. a list starting with `not`).
182−complementableListSetting :: String
183− -> ExportSettingSetter (Either [String] [String])
184− -> OrgParser ()
185−complementableListSetting settingIdentifier setter = try $ do
186− _ <- string settingIdentifier <* char ':'
187− value <- choice [ Left <$> complementStringList
188− , Right <$> stringList
189− , (\b -> if b then Left [] else Right []) <$> elispBoolean
190− ]
191− updateState $ modifyExportSettings setter value
192− where
193− -- Read a plain list of strings.
194− stringList :: OrgParser [String]
195− stringList = try $
196− char '('
197− *> sepBy elispString spaces
198− <* char ')'
199−
200− -- Read an emacs lisp list specifying a complement set.
201− complementStringList :: OrgParser [String]
202− complementStringList = try $
203− string "(not "
204− *> sepBy elispString spaces
205− <* char ')'
206−
207− elispString :: OrgParser String
208− elispString = try $
209− char '"'
210− *> manyTill alphaNum (char '"')
211−
212−ignoredSetting :: String -> OrgParser ()
213−ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)
214−
21547--
21648-- Parser
21749--
21850parseOrg :: OrgParser Pandoc
21951parseOrg = do
220− blocks' <- parseBlocks
221− st <- getState
222− let meta = runF (orgStateMeta' st) st
223− let removeUnwantedBlocks = dropCommentTrees . filter (/= Null)
224− return $ Pandoc meta $ removeUnwantedBlocks (B.toList $ runF blocks' st)
52+ blocks' <- blockList
53+ meta' <- meta
54+ return . Pandoc meta' $ removeUnwantedBlocks blocks'
55+ where
56+ removeUnwantedBlocks :: [Block] -> [Block]
57+ removeUnwantedBlocks = dropCommentTrees . filter (/= Null)
22558
22659-- | Drop COMMENT headers and the document tree below those headers.
22760dropCommentTrees :: [Block] -> [Block]
@@ -256,1452 +89,3 @@ isHeaderLevelLowerEq n blk =
25689 case blk of
25790 (Header level _ _) -> n >= level
25891 _ -> False
259−
260−
261−--
262−-- Adaptions and specializations of parsing utilities
263−--
264−
265−-- The version Text.Pandoc.Parsing cannot be used, as we need additional parts
266−-- of the state saved and restored.
267−parseFromString :: OrgParser a -> String -> OrgParser a
268−parseFromString parser str' = do
269− oldLastPreCharPos <- orgStateLastPreCharPos <$> getState
270− updateState $ \s -> s{ orgStateLastPreCharPos = Nothing }
271− result <- P.parseFromString parser str'
272− updateState $ \s -> s{ orgStateLastPreCharPos = oldLastPreCharPos }
273− return result
274−
275−-- | Like @Text.Parsec.Char.newline@, but causes additional state changes.
276−newline :: OrgParser Char
277−newline =
278− P.newline
279− <* updateLastPreCharPos
280− <* updateLastForbiddenCharPos
281−
282−-- | Like @Text.Parsec.Char.blanklines@, but causes additional state changes.
283−blanklines :: OrgParser [Char]
284−blanklines =
285− P.blanklines
286− <* updateLastPreCharPos
287− <* updateLastForbiddenCharPos
288−
289−anyLine :: OrgParser String
290−anyLine =
291− P.anyLine
292− <* updateLastPreCharPos
293− <* updateLastForbiddenCharPos
294−
295−-- | Succeeds when we're in list context.
296−inList :: OrgParser ()
297−inList = do
298− ctx <- orgStateParserContext <$> getState
299− guard (ctx == ListItemState)
300−
301−-- | Parse in different context
302−withContext :: ParserContext -- ^ New parser context
303− -> OrgParser a -- ^ Parser to run in that context
304− -> OrgParser a
305−withContext context parser = do
306− oldContext <- orgStateParserContext <$> getState
307− updateState $ \s -> s{ orgStateParserContext = context }
308− result <- parser
309− updateState $ \s -> s{ orgStateParserContext = oldContext }
310− return result
311−
312−--
313−-- parsing blocks
314−--
315−
316−parseBlocks :: OrgParser (F Blocks)
317−parseBlocks = mconcat <$> manyTill block eof
318−
319−block :: OrgParser (F Blocks)
320−block = choice [ mempty <$ blanklines
321− , table
322− , orgBlock
323− , figure
324− , example
325− , genericDrawer
326− , specialLine
327− , header
328− , return <$> hline
329− , list
330− , latexFragment
331− , noteBlock
332− , paraOrPlain
333− ] <?> "block"
334−
335−
336−--
337−-- Block Attributes
338−--
339−
340−-- | Attributes that may be added to figures (like a name or caption).
341−data BlockAttributes = BlockAttributes
342− { blockAttrName :: Maybe String
343− , blockAttrCaption :: Maybe (F Inlines)
344− , blockAttrKeyValues :: [(String, String)]
345− }
346−
347−stringyMetaAttribute :: (String -> Bool) -> OrgParser (String, String)
348−stringyMetaAttribute attrCheck = try $ do
349− metaLineStart
350− attrName <- map toUpper <$> many1Till nonspaceChar (char ':')
351− guard $ attrCheck attrName
352− skipSpaces
353− attrValue <- anyLine
354− return (attrName, attrValue)
355−
356−blockAttributes :: OrgParser BlockAttributes
357−blockAttributes = try $ do
358− kv <- many (stringyMetaAttribute attrCheck)
359− let caption = foldl' (appendValues "CAPTION") Nothing kv
360− let kvAttrs = foldl' (appendValues "ATTR_HTML") Nothing kv
361− let name = lookup "NAME" kv
362− caption' <- maybe (return Nothing)
363− (fmap Just . parseFromString parseInlines)
364− caption
365− kvAttrs' <- parseFromString keyValues . (++ "\n") $ fromMaybe mempty kvAttrs
366− return $ BlockAttributes
367− { blockAttrName = name
368− , blockAttrCaption = caption'
369− , blockAttrKeyValues = kvAttrs'
370− }
371− where
372− attrCheck :: String -> Bool
373− attrCheck attr =
374− case attr of
375− "NAME" -> True
376− "CAPTION" -> True
377− "ATTR_HTML" -> True
378− _ -> False
379−
380− appendValues :: String -> Maybe String -> (String, String) -> Maybe String
381− appendValues attrName accValue (key, value) =
382− if key /= attrName
383− then accValue
384− else case accValue of
385− Just acc -> Just $ acc ++ ' ':value
386− Nothing -> Just value
387−
388−keyValues :: OrgParser [(String, String)]
389−keyValues = try $
390− manyTill ((,) <$> key <*> value) newline
391− where
392− key :: OrgParser String
393− key = try $ skipSpaces *> char ':' *> many1 nonspaceChar
394−
395− value :: OrgParser String
396− value = skipSpaces *> manyTill anyChar endOfValue
397−
398− endOfValue :: OrgParser ()
399− endOfValue =
400− lookAhead $ (() <$ try (many1 spaceChar <* key))
401− <|> () <$ P.newline
402−
403−
404−--
405−-- Org Blocks (#+BEGIN_... / #+END_...)
406−--
407−
408−type BlockProperties = (Int, String) -- (Indentation, Block-Type)
409−
410−updateIndent :: BlockProperties -> Int -> BlockProperties
411−updateIndent (_, blkType) indent = (indent, blkType)
412−
413−orgBlock :: OrgParser (F Blocks)
414−orgBlock = try $ do
415− blockAttrs <- blockAttributes
416− blockProp@(_, blkType) <- blockHeaderStart
417− ($ blockProp) $
418− case blkType of
419− "comment" -> withRaw' (const mempty)
420− "html" -> withRaw' (return . (B.rawBlock blkType))
421− "latex" -> withRaw' (return . (B.rawBlock blkType))
422− "ascii" -> withRaw' (return . (B.rawBlock blkType))
423− "example" -> withRaw' (return . exampleCode)
424− "quote" -> withParsed (fmap B.blockQuote)
425− "verse" -> verseBlock
426− "src" -> codeBlock blockAttrs
427− _ -> withParsed (fmap $ divWithClass blkType)
428−
429−blockHeaderStart :: OrgParser (Int, String)
430−blockHeaderStart = try $ (,) <$> indentation <*> blockType
431− where
432− blockType = map toLower <$> (stringAnyCase "#+begin_" *> orgArgWord)
433−
434−indentation :: OrgParser Int
435−indentation = try $ do
436− tabStop <- getOption readerTabStop
437− s <- many spaceChar
438− return $ spaceLength tabStop s
439−
440−spaceLength :: Int -> String -> Int
441−spaceLength tabStop s = (sum . map charLen) s
442− where
443− charLen ' ' = 1
444− charLen '\t' = tabStop
445− charLen _ = 0
446−
447−withRaw' :: (String -> F Blocks) -> BlockProperties -> OrgParser (F Blocks)
448−withRaw' f blockProp = (ignHeaders *> (f <$> rawBlockContent blockProp))
449−
450−withParsed :: (F Blocks -> F Blocks) -> BlockProperties -> OrgParser (F Blocks)
451−withParsed f blockProp = (ignHeaders *> (f <$> parsedBlockContent blockProp))
452−
453−ignHeaders :: OrgParser ()
454−ignHeaders = (() <$ newline) <|> (() <$ anyLine)
455−
456−divWithClass :: String -> Blocks -> Blocks
457−divWithClass cls = B.divWith ("", [cls], [])
458−
459−verseBlock :: BlockProperties -> OrgParser (F Blocks)
460−verseBlock blkProp = try $ do
461− ignHeaders
462− content <- rawBlockContent blkProp
463− fmap B.para . mconcat . intersperse (pure B.linebreak)
464− <$> mapM (parseFromString parseInlines) (map (++ "\n") . lines $ content)
465−
466−exportsCode :: [(String, String)] -> Bool
467−exportsCode attrs = not (("rundoc-exports", "none") `elem` attrs
468− || ("rundoc-exports", "results") `elem` attrs)
469−
470−exportsResults :: [(String, String)] -> Bool
471−exportsResults attrs = ("rundoc-exports", "results") `elem` attrs
472− || ("rundoc-exports", "both") `elem` attrs
473−
474−followingResultsBlock :: OrgParser (Maybe (F Blocks))
475−followingResultsBlock =
476− optionMaybe (try $ blanklines *> stringAnyCase "#+RESULTS:"
477− *> blankline
478− *> block)
479−
480−codeBlock :: BlockAttributes -> BlockProperties -> OrgParser (F Blocks)
481−codeBlock blockAttrs blkProp = do
482− skipSpaces
483− (classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders)
484− leadingIndent <- lookAhead indentation
485− content <- rawBlockContent (updateIndent blkProp leadingIndent)
486− resultsContent <- followingResultsBlock
487− let id' = fromMaybe mempty $ blockAttrName blockAttrs
488− let includeCode = exportsCode kv
489− let includeResults = exportsResults kv
490− let codeBlck = B.codeBlockWith ( id', classes, kv ) content
491− let labelledBlck = maybe (pure codeBlck)
492− (labelDiv codeBlck)
493− (blockAttrCaption blockAttrs)
494− let resultBlck = fromMaybe mempty resultsContent
495− return $ (if includeCode then labelledBlck else mempty)
496− <> (if includeResults then resultBlck else mempty)
497− where
498− labelDiv blk value =
499− B.divWith nullAttr <$> (mappend <$> labelledBlock value
500− <*> pure blk)
501− labelledBlock = fmap (B.plain . B.spanWith ("", ["label"], []))
502−
503−rawBlockContent :: BlockProperties -> OrgParser String
504−rawBlockContent (indent, blockType) = try $
505− unlines . map commaEscaped <$> manyTill indentedLine blockEnder
506− where
507− indentedLine = try $ ("" <$ blankline) <|> (indentWith indent *> anyLine)
508− blockEnder = try $ skipSpaces *> stringAnyCase ("#+end_" <> blockType)
509−
510−parsedBlockContent :: BlockProperties -> OrgParser (F Blocks)
511−parsedBlockContent blkProps = try $ do
512− raw <- rawBlockContent blkProps
513− parseFromString parseBlocks (raw ++ "\n")
514−
515−-- indent by specified number of spaces (or equiv. tabs)
516−indentWith :: Int -> OrgParser String
517−indentWith num = do
518− tabStop <- getOption readerTabStop
519− if num < tabStop
520− then count num (char ' ')
521− else choice [ try (count num (char ' '))
522− , try (char '\t' >> count (num - tabStop) (char ' ')) ]
523−
524−type SwitchOption = (Char, Maybe String)
525−
526−orgArgWord :: OrgParser String
527−orgArgWord = many1 orgArgWordChar
528−
529−-- | Parse code block arguments
530−-- TODO: We currently don't handle switches.
531−codeHeaderArgs :: OrgParser ([String], [(String, String)])
532−codeHeaderArgs = try $ do
533− language <- skipSpaces *> orgArgWord
534− _ <- skipSpaces *> (try $ switch `sepBy` (many1 spaceChar))
535− parameters <- manyTill blockOption newline
536− let pandocLang = translateLang language
537− return $
538− if hasRundocParameters parameters
539− then ( [ pandocLang, rundocBlockClass ]
540− , map toRundocAttrib (("language", language) : parameters)
541− )
542− else ([ pandocLang ], parameters)
543− where hasRundocParameters = not . null
544−
545−switch :: OrgParser SwitchOption
546−switch = try $ simpleSwitch <|> lineNumbersSwitch
547− where
548− simpleSwitch = (\c -> (c, Nothing)) <$> (oneOf "-+" *> letter)
549− lineNumbersSwitch = (\ls -> ('l', Just ls)) <$>
550− (string "-l \"" *> many1Till nonspaceChar (char '"'))
551−
552−translateLang :: String -> String
553−translateLang "C" = "c"
554−translateLang "C++" = "cpp"
555−translateLang "emacs-lisp" = "commonlisp" -- emacs lisp is not supported
556−translateLang "js" = "javascript"
557−translateLang "lisp" = "commonlisp"
558−translateLang "R" = "r"
559−translateLang "sh" = "bash"
560−translateLang "sqlite" = "sql"
561−translateLang cs = cs
562−
563−-- | Prefix used for Rundoc classes and arguments.
564−rundocPrefix :: String
565−rundocPrefix = "rundoc-"
566−
567−-- | The class-name used to mark rundoc blocks.
568−rundocBlockClass :: String
569−rundocBlockClass = rundocPrefix ++ "block"
570−
571−blockOption :: OrgParser (String, String)
572−blockOption = try $ do
573− argKey <- orgArgKey
574− paramValue <- option "yes" orgParamValue
575− return (argKey, paramValue)
576−
577−inlineBlockOption :: OrgParser (String, String)
578−inlineBlockOption = try $ do
579− argKey <- orgArgKey
580− paramValue <- option "yes" orgInlineParamValue
581− return (argKey, paramValue)
582−
583−orgArgKey :: OrgParser String
584−orgArgKey = try $
585− skipSpaces *> char ':'
586− *> many1 orgArgWordChar
587−
588−orgParamValue :: OrgParser String
589−orgParamValue = try $
590− skipSpaces
591− *> notFollowedBy (char ':' )
592− *> many1 (noneOf "\t\n\r ")
593− <* skipSpaces
594−
595−orgInlineParamValue :: OrgParser String
596−orgInlineParamValue = try $
597− skipSpaces
598− *> notFollowedBy (char ':')
599− *> many1 (noneOf "\t\n\r ]")
600− <* skipSpaces
601−
602−orgArgWordChar :: OrgParser Char
603−orgArgWordChar = alphaNum <|> oneOf "-_"
604−
605−toRundocAttrib :: (String, String) -> (String, String)
606−toRundocAttrib = first ("rundoc-" ++)
607−
608−commaEscaped :: String -> String
609−commaEscaped (',':cs@('*':_)) = cs
610−commaEscaped (',':cs@('#':'+':_)) = cs
611−commaEscaped cs = cs
612−
613−example :: OrgParser (F Blocks)
614−example = try $ do
615− return . return . exampleCode =<< unlines <$> many1 exampleLine
616−
617−exampleCode :: String -> Blocks
618−exampleCode = B.codeBlockWith ("", ["example"], [])
619−
620−exampleLine :: OrgParser String
621−exampleLine = try $ skipSpaces *> string ": " *> anyLine
622−
623−
624−--
625−-- Drawers
626−--
627−
628−-- | A generic drawer which has no special meaning for org-mode.
629−-- Whether or not this drawer is included in the output depends on the drawers
630−-- export setting.
631−genericDrawer :: OrgParser (F Blocks)
632−genericDrawer = try $ do
633− name <- map toUpper <$> drawerStart
634− content <- manyTill drawerLine (try drawerEnd)
635− state <- getState
636− -- Include drawer if it is explicitly included in or not explicitly excluded
637− -- from the list of drawers that should be exported. PROPERTIES drawers are
638− -- never exported.
639− case (exportDrawers . orgStateExportSettings $ state) of
640− _ | name == "PROPERTIES" -> return mempty
641− Left names | name `elem` names -> return mempty
642− Right names | name `notElem` names -> return mempty
643− _ -> drawerDiv name <$> parseLines content
644− where
645− parseLines :: [String] -> OrgParser (F Blocks)
646− parseLines = parseFromString parseBlocks . (++ "\n") . unlines
647−
648− drawerDiv :: String -> F Blocks -> F Blocks
649− drawerDiv drawerName = fmap $ B.divWith (mempty, [drawerName, "drawer"], mempty)
650−
651−drawerStart :: OrgParser String
652−drawerStart = try $
653− skipSpaces *> drawerName <* skipSpaces <* newline
654− where drawerName = char ':' *> manyTill nonspaceChar (char ':')
655−
656−drawerLine :: OrgParser String
657−drawerLine = anyLine
658−
659−drawerEnd :: OrgParser String
660−drawerEnd = try $
661− skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
662−
663−-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
664−-- within.
665−propertiesDrawer :: OrgParser [(String, String)]
666−propertiesDrawer = try $ do
667− drawerType <- drawerStart
668− guard $ map toUpper drawerType == "PROPERTIES"
669− manyTill property (try drawerEnd)
670− where
671− property :: OrgParser (String, String)
672− property = try $ (,) <$> key <*> value
673−
674− key :: OrgParser String
675− key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
676−
677− value :: OrgParser String
678− value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> P.newline)
679−
680−keyValuesToAttr :: [(String, String)] -> Attr
681−keyValuesToAttr kvs =
682− let
683− lowerKvs = map (\(k, v) -> (map toLower k, v)) kvs
684− id' = fromMaybe mempty . lookup "custom_id" $ lowerKvs
685− cls = fromMaybe mempty . lookup "class" $ lowerKvs
686− kvs' = filter (flip notElem ["custom_id", "class"] . fst) lowerKvs
687− in
688− (id', words cls, kvs')
689−
690−
691−--
692−-- Figures
693−--
694−
695−-- | Figures (Image on a line by itself, preceded by name and/or caption)
696−figure :: OrgParser (F Blocks)
697−figure = try $ do
698− figAttrs <- blockAttributes
699− src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline
700− guard . not . isNothing . blockAttrCaption $ figAttrs
701− guard (isImageFilename src)
702− let figName = fromMaybe mempty $ blockAttrName figAttrs
703− let figCaption = fromMaybe mempty $ blockAttrCaption figAttrs
704− let figKeyVals = blockAttrKeyValues figAttrs
705− let attr = (mempty, mempty, figKeyVals)
706− return $ (B.para . B.imageWith attr src (withFigPrefix figName) <$> figCaption)
707− where
708− withFigPrefix cs =
709− if "fig:" `isPrefixOf` cs
710− then cs
711− else "fig:" ++ cs
712−
713−--
714−-- Comments, Options and Metadata
715−--
716−specialLine :: OrgParser (F Blocks)
717−specialLine = fmap return . try $ metaLine <|> commentLine
718−
719−metaLine :: OrgParser Blocks
720−metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)
721−
722−-- The order, in which blocks are tried, makes sure that we're not looking at
723−-- the beginning of a block, so we don't need to check for it
724−metaLineStart :: OrgParser ()
725−metaLineStart = try $ skipSpaces <* string "#+"
726−
727−commentLine :: OrgParser Blocks
728−commentLine = commentLineStart *> anyLine *> pure mempty
729−
730−commentLineStart :: OrgParser ()
731−commentLineStart = try $ skipSpaces <* string "# "
732−
733−declarationLine :: OrgParser ()
734−declarationLine = try $ do
735− key <- metaKey
736− inlinesF <- metaInlines
737− updateState $ \st ->
738− let meta' = B.setMeta <$> pure key <*> inlinesF <*> pure nullMeta
739− in st { orgStateMeta' = orgStateMeta' st <> meta' }
740− return ()
741−
742−metaInlines :: OrgParser (F MetaValue)
743−metaInlines = fmap (MetaInlines . B.toList) <$> inlinesTillNewline
744−
745−metaKey :: OrgParser String
746−metaKey = map toLower <$> many1 (noneOf ": \n\r")
747− <* char ':'
748− <* skipSpaces
749−
750−optionLine :: OrgParser ()
751−optionLine = try $ do
752− key <- metaKey
753− case key of
754− "link" -> parseLinkFormat >>= uncurry addLinkFormat
755− "options" -> () <$ sepBy spaces exportSetting
756− _ -> mzero
757−
758−parseLinkFormat :: OrgParser ((String, String -> String))
759−parseLinkFormat = try $ do
760− linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces
761− linkSubst <- parseFormat
762− return (linkType, linkSubst)
763−
764−-- | An ad-hoc, single-argument-only implementation of a printf-style format
765−-- parser.
766−parseFormat :: OrgParser (String -> String)
767−parseFormat = try $ do
768− replacePlain <|> replaceUrl <|> justAppend
769− where
770− -- inefficient, but who cares
771− replacePlain = try $ (\x -> concat . flip intersperse x)
772− <$> sequence [tillSpecifier 's', rest]
773− replaceUrl = try $ (\x -> concat . flip intersperse x . urlEncode)
774− <$> sequence [tillSpecifier 'h', rest]
775− justAppend = try $ (++) <$> rest
776−
777− rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r")
778− tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:""))
779−
780−--
781−-- Headers
782−--
783−
784−-- | Headers
785−header :: OrgParser (F Blocks)
786−header = try $ do
787− level <- headerStart
788− title <- manyTill inline (lookAhead $ optional headerTags <* P.newline)
789− tags <- option [] headerTags
790− newline
791− propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)
792− inlines <- runF (tagTitle title tags) <$> getState
793− attr <- registerHeader propAttr inlines
794− return $ pure (B.headerWith attr level inlines)
795− where
796− tagTitle :: [F Inlines] -> [String] -> F Inlines
797− tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags
798−
799− tagToInlineF :: String -> F Inlines
800− tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
801−
802− headerTags :: OrgParser [String]
803− headerTags = try $
804− let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
805− in skipSpaces
806− *> char ':'
807− *> many1 tag
808− <* skipSpaces
809−
810−headerStart :: OrgParser Int
811−headerStart = try $
812− (length <$> many1 (char '*')) <* many1 (char ' ') <* updateLastPreCharPos
813−
814−
815−-- Don't use (or need) the reader wrapper here, we want hline to be
816−-- @show@able. Otherwise we can't use it with @notFollowedBy'@.
817−
818−-- | Horizontal Line (five -- dashes or more)
819−hline :: OrgParser Blocks
820−hline = try $ do
821− skipSpaces
822− string "-----"
823− many (char '-')
824− skipSpaces
825− newline
826− return B.horizontalRule
827−
828−--
829−-- Tables
830−--
831−
832−data OrgTableRow = OrgContentRow (F [Blocks])
833− | OrgAlignRow [Alignment]
834− | OrgHlineRow
835−
836−-- OrgTable is strongly related to the pandoc table ADT. Using the same
837−-- (i.e. pandoc-global) ADT would mean that the reader would break if the
838−-- global structure was to be changed, which would be bad. The final table
839−-- should be generated using a builder function. Column widths aren't
840−-- implemented yet, so they are not tracked here.
841−data OrgTable = OrgTable
842− { orgTableAlignments :: [Alignment]
843− , orgTableHeader :: [Blocks]
844− , orgTableRows :: [[Blocks]]
845− }
846−
847−table :: OrgParser (F Blocks)
848−table = try $ do
849− blockAttrs <- blockAttributes
850− lookAhead tableStart
851− do
852− rows <- tableRows
853− let caption = fromMaybe (return mempty) $ blockAttrCaption blockAttrs
854− return $ (<$> caption) . orgToPandocTable . normalizeTable =<< rowsToTable rows
855−
856−orgToPandocTable :: OrgTable
857− -> Inlines
858− -> Blocks
859−orgToPandocTable (OrgTable aligns heads lns) caption =
860− B.table caption (zip aligns $ repeat 0) heads lns
861−
862−tableStart :: OrgParser Char
863−tableStart = try $ skipSpaces *> char '|'
864−
865−tableRows :: OrgParser [OrgTableRow]
866−tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow)
867−
868−tableContentRow :: OrgParser OrgTableRow
869−tableContentRow = try $
870− OrgContentRow . sequence <$> (tableStart *> many1Till tableContentCell newline)
871−
872−tableContentCell :: OrgParser (F Blocks)
873−tableContentCell = try $
874− fmap B.plain . trimInlinesF . mconcat <$> manyTill inline endOfCell
875−
876−tableAlignRow :: OrgParser OrgTableRow
877−tableAlignRow = try $ do
878− tableStart
879− cells <- many1Till tableAlignCell newline
880− -- Empty rows are regular (i.e. content) rows, not alignment rows.
881− guard $ any (/= AlignDefault) cells
882− return $ OrgAlignRow cells
883−
884−tableAlignCell :: OrgParser Alignment
885−tableAlignCell =
886− choice [ try $ emptyCell *> return AlignDefault
887− , try $ skipSpaces
888− *> char '<'
889− *> tableAlignFromChar
890− <* many digit
891− <* char '>'
892− <* emptyCell
893− ] <?> "alignment info"
894− where emptyCell = try $ skipSpaces *> endOfCell
895−
896−tableAlignFromChar :: OrgParser Alignment
897−tableAlignFromChar = try $
898− choice [ char 'l' *> return AlignLeft
899− , char 'c' *> return AlignCenter
900− , char 'r' *> return AlignRight
901− ]
902−
903−tableHline :: OrgParser OrgTableRow
904−tableHline = try $
905− OrgHlineRow <$ (tableStart *> char '-' *> anyLine)
906−
907−endOfCell :: OrgParser Char
908−endOfCell = try $ char '|' <|> lookAhead newline
909−
910−rowsToTable :: [OrgTableRow]
911− -> F OrgTable
912−rowsToTable = foldM rowToContent emptyTable
913− where emptyTable = OrgTable mempty mempty mempty
914−
915−normalizeTable :: OrgTable -> OrgTable
916−normalizeTable (OrgTable aligns heads rows) = OrgTable aligns' heads rows
917− where
918− refRow = if heads /= mempty
919− then heads
920− else if rows == mempty then mempty else head rows
921− cols = length refRow
922− fillColumns base padding = take cols $ base ++ repeat padding
923− aligns' = fillColumns aligns AlignDefault
924−
925−-- One or more horizontal rules after the first content line mark the previous
926−-- line as a header. All other horizontal lines are discarded.
927−rowToContent :: OrgTable
928− -> OrgTableRow
929− -> F OrgTable
930−rowToContent orgTable row =
931− case row of
932− OrgHlineRow -> return singleRowPromotedToHeader
933− OrgAlignRow as -> return . setAligns $ as
934− OrgContentRow cs -> appendToBody cs
935− where
936− singleRowPromotedToHeader :: OrgTable
937− singleRowPromotedToHeader = case orgTable of
938− OrgTable{ orgTableHeader = [], orgTableRows = b:[] } ->
939− orgTable{ orgTableHeader = b , orgTableRows = [] }
940− _ -> orgTable
941−
942− setAligns :: [Alignment] -> OrgTable
943− setAligns aligns = orgTable{ orgTableAlignments = aligns }
944−
945− appendToBody :: F [Blocks] -> F OrgTable
946− appendToBody frow = do
947− newRow <- frow
948− let oldRows = orgTableRows orgTable
949− -- NOTE: This is an inefficient O(n) operation. This should be changed
950− -- if performance ever becomes a problem.
951− return orgTable{ orgTableRows = oldRows ++ [newRow] }
952−
953−
954−--
955−-- LaTeX fragments
956−--
957−latexFragment :: OrgParser (F Blocks)
958−latexFragment = try $ do
959− envName <- latexEnvStart
960− content <- mconcat <$> manyTill anyLineNewline (latexEnd envName)
961− return . return $ B.rawBlock "latex" (content `inLatexEnv` envName)
962− where
963− c `inLatexEnv` e = mconcat [ "\\begin{", e, "}\n"
964− , c
965− , "\\end{", e, "}\n"
966− ]
967−
968−latexEnvStart :: OrgParser String
969−latexEnvStart = try $ do
970− skipSpaces *> string "\\begin{"
971− *> latexEnvName
972− <* string "}"
973− <* blankline
974−
975−latexEnd :: String -> OrgParser ()
976−latexEnd envName = try $
977− () <$ skipSpaces
978− <* string ("\\end{" ++ envName ++ "}")
979− <* blankline
980−
981−-- | Parses a LaTeX environment name.
982−latexEnvName :: OrgParser String
983−latexEnvName = try $ do
984− mappend <$> many1 alphaNum
985− <*> option "" (string "*")
986−
987−
988−--
989−-- Footnote defintions
990−--
991−noteBlock :: OrgParser (F Blocks)
992−noteBlock = try $ do
993− ref <- noteMarker <* skipSpaces
994− content <- mconcat <$> blocksTillHeaderOrNote
995− addToNotesTable (ref, content)
996− return mempty
997− where
998− blocksTillHeaderOrNote =
999− many1Till block (eof <|> () <$ lookAhead noteMarker
1000− <|> () <$ lookAhead headerStart)
1001−
1002−-- Paragraphs or Plain text
1003−paraOrPlain :: OrgParser (F Blocks)
1004−paraOrPlain = try $ do
1005− ils <- parseInlines
1006− nl <- option False (newline *> return True)
1007− -- Read block as paragraph, except if we are in a list context and the block
1008− -- is directly followed by a list item, in which case the block is read as
1009− -- plain text.
1010− try (guard nl
1011− *> notFollowedBy (inList *> (orderedListStart <|> bulletListStart))
1012− *> return (B.para <$> ils))
1013− <|> (return (B.plain <$> ils))
1014−
1015−inlinesTillNewline :: OrgParser (F Inlines)
1016−inlinesTillNewline = trimInlinesF . mconcat <$> manyTill inline newline
1017−
1018−
1019−--
1020−-- list blocks
1021−--
1022−
1023−list :: OrgParser (F Blocks)
1024−list = choice [ definitionList, bulletList, orderedList ] <?> "list"
1025−
1026−definitionList :: OrgParser (F Blocks)
1027−definitionList = try $ do n <- lookAhead (bulletListStart' Nothing)
1028− fmap B.definitionList . fmap compactify'DL . sequence
1029− <$> many1 (definitionListItem $ bulletListStart' (Just n))
1030−
1031−bulletList :: OrgParser (F Blocks)
1032−bulletList = try $ do n <- lookAhead (bulletListStart' Nothing)
1033− fmap B.bulletList . fmap compactify' . sequence
1034− <$> many1 (listItem (bulletListStart' $ Just n))
1035−
1036−orderedList :: OrgParser (F Blocks)
1037−orderedList = fmap B.orderedList . fmap compactify' . sequence
1038− <$> many1 (listItem orderedListStart)
1039−
1040−genericListStart :: OrgParser String
1041− -> OrgParser Int
1042−genericListStart listMarker = try $
1043− (+) <$> (length <$> many spaceChar)
1044− <*> (length <$> listMarker <* many1 spaceChar)
1045−
1046−-- parses bullet list marker. maybe we know the indent level
1047−bulletListStart :: OrgParser Int
1048−bulletListStart = bulletListStart' Nothing
1049−
1050−bulletListStart' :: Maybe Int -> OrgParser Int
1051−-- returns length of bulletList prefix, inclusive of marker
1052−bulletListStart' Nothing = do ind <- length <$> many spaceChar
1053− when (ind == 0) $ notFollowedBy (char '*')
1054− oneOf bullets
1055− many1 spaceChar
1056− return (ind + 1)
1057− -- Unindented lists are legal, but they can't use '*' bullets
1058− -- We return n to maintain compatibility with the generic listItem
1059−bulletListStart' (Just n) = do count (n-1) spaceChar
1060− when (n == 1) $ notFollowedBy (char '*')
1061− oneOf bullets
1062− many1 spaceChar
1063− return n
1064−
1065−bullets :: String
1066−bullets = "*+-"
1067−
1068−orderedListStart :: OrgParser Int
1069−orderedListStart = genericListStart orderedListMarker
1070− -- Ordered list markers allowed in org-mode
1071− where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)")
1072−
1073−definitionListItem :: OrgParser Int
1074− -> OrgParser (F (Inlines, [Blocks]))
1075−definitionListItem parseMarkerGetLength = try $ do
1076− markerLength <- parseMarkerGetLength
1077− term <- manyTill (noneOf "\n\r") (try definitionMarker)
1078− line1 <- anyLineNewline
1079− blank <- option "" ("\n" <$ blankline)
1080− cont <- concat <$> many (listContinuation markerLength)
1081− term' <- parseFromString parseInlines term
1082− contents' <- parseFromString parseBlocks $ line1 ++ blank ++ cont
1083− return $ (,) <$> term' <*> fmap (:[]) contents'
1084− where
1085− definitionMarker =
1086− spaceChar *> string "::" <* (spaceChar <|> lookAhead P.newline)
1087−
1088−
1089−-- parse raw text for one list item, excluding start marker and continuations
1090−listItem :: OrgParser Int
1091− -> OrgParser (F Blocks)
1092−listItem start = try . withContext ListItemState $ do
1093− markerLength <- try start
1094− firstLine <- anyLineNewline
1095− blank <- option "" ("\n" <$ blankline)
1096− rest <- concat <$> many (listContinuation markerLength)
1097− parseFromString parseBlocks $ firstLine ++ blank ++ rest
1098−
1099−-- continuation of a list item - indented and separated by blankline or endline.
1100−-- Note: nested lists are parsed as continuations.
1101−listContinuation :: Int
1102− -> OrgParser String
1103−listContinuation markerLength = try $
1104− notFollowedBy' blankline
1105− *> (mappend <$> (concat <$> many1 listLine)
1106− <*> many blankline)
1107− where listLine = try $ indentWith markerLength *> anyLineNewline
1108−
1109−anyLineNewline :: OrgParser String
1110−anyLineNewline = (++ "\n") <$> anyLine
1111−
1112−
1113−--
1114−-- inline
1115−--
1116−
1117−inline :: OrgParser (F Inlines)
1118−inline =
1119− choice [ whitespace
1120− , linebreak
1121− , cite
1122− , footnote
1123− , linkOrImage
1124− , anchor
1125− , inlineCodeBlock
1126− , str
1127− , endline
1128− , emph
1129− , strong
1130− , strikeout
1131− , underline
1132− , code
1133− , math
1134− , displayMath
1135− , verbatim
1136− , subscript
1137− , superscript
1138− , inlineLaTeX
1139− , smart
1140− , symbol
1141− ] <* (guard =<< newlinesCountWithinLimits)
1142− <?> "inline"
1143−
1144−parseInlines :: OrgParser (F Inlines)
1145−parseInlines = trimInlinesF . mconcat <$> many1 inline
1146−
1147−-- treat these as potentially non-text when parsing inline:
1148−specialChars :: [Char]
1149−specialChars = "\"$'()*+-,./:<=>[\\]^_{|}~"
1150−
1151−
1152−whitespace :: OrgParser (F Inlines)
1153−whitespace = pure B.space <$ skipMany1 spaceChar
1154− <* updateLastPreCharPos
1155− <* updateLastForbiddenCharPos
1156− <?> "whitespace"
1157−
1158−linebreak :: OrgParser (F Inlines)
1159−linebreak = try $ pure B.linebreak <$ string "\\\\" <* skipSpaces <* newline
1160−
1161−str :: OrgParser (F Inlines)
1162−str = return . B.str <$> many1 (noneOf $ specialChars ++ "\n\r ")
1163− <* updateLastStrPos
1164−
1165−-- | An endline character that can be treated as a space, not a structural
1166−-- break. This should reflect the values of the Emacs variable
1167−-- @org-element-pagaraph-separate@.
1168−endline :: OrgParser (F Inlines)
1169−endline = try $ do
1170− newline
1171− notFollowedBy blankline
1172− notFollowedBy' exampleLine
1173− notFollowedBy' hline
1174− notFollowedBy' noteMarker
1175− notFollowedBy' tableStart
1176− notFollowedBy' drawerStart
1177− notFollowedBy' headerStart
1178− notFollowedBy' metaLineStart
1179− notFollowedBy' latexEnvStart
1180− notFollowedBy' commentLineStart
1181− notFollowedBy' bulletListStart
1182− notFollowedBy' orderedListStart
1183− decEmphasisNewlinesCount
1184− guard =<< newlinesCountWithinLimits
1185− updateLastPreCharPos
1186− return . return $ B.softbreak
1187−
1188−cite :: OrgParser (F Inlines)
1189−cite = try $ do
1190− guardEnabled Ext_citations
1191− (cs, raw) <- withRaw normalCite
1192− return $ (flip B.cite (B.text raw)) <$> cs
1193−
1194−normalCite :: OrgParser (F [Citation])
1195−normalCite = try $ char '['
1196− *> skipSpaces
1197− *> citeList
1198− <* skipSpaces
1199− <* char ']'
1200−
1201−citeList :: OrgParser (F [Citation])
1202−citeList = sequence <$> sepBy1 citation (try $ char ';' *> skipSpaces)
1203−
1204−citation :: OrgParser (F Citation)
1205−citation = try $ do
1206− pref <- prefix
1207− (suppress_author, key) <- citeKey
1208− suff <- suffix
1209− return $ do
1210− x <- pref
1211− y <- suff
1212− return $ Citation{ citationId = key
1213− , citationPrefix = B.toList x
1214− , citationSuffix = B.toList y
1215− , citationMode = if suppress_author
1216− then SuppressAuthor
1217− else NormalCitation
1218− , citationNoteNum = 0
1219− , citationHash = 0
1220− }
1221− where
1222− prefix = trimInlinesF . mconcat <$>
1223− manyTill inline (char ']' <|> (']' <$ lookAhead citeKey))
1224− suffix = try $ do
1225− hasSpace <- option False (notFollowedBy nonspaceChar >> return True)
1226− skipSpaces
1227− rest <- trimInlinesF . mconcat <$>
1228− many (notFollowedBy (oneOf ";]") *> inline)
1229− return $ if hasSpace
1230− then (B.space <>) <$> rest
1231− else rest
1232−
1233−footnote :: OrgParser (F Inlines)
1234−footnote = try $ inlineNote <|> referencedNote
1235−
1236−inlineNote :: OrgParser (F Inlines)
1237−inlineNote = try $ do
1238− string "[fn:"
1239− ref <- many alphaNum
1240− char ':'
1241− note <- fmap B.para . trimInlinesF . mconcat <$> many1Till inline (char ']')
1242− when (not $ null ref) $
1243− addToNotesTable ("fn:" ++ ref, note)
1244− return $ B.note <$> note
1245−
1246−referencedNote :: OrgParser (F Inlines)
1247−referencedNote = try $ do
1248− ref <- noteMarker
1249− return $ do
1250− notes <- asksF orgStateNotes'
1251− case lookup ref notes of
1252− Nothing -> return $ B.str $ "[" ++ ref ++ "]"
1253− Just contents -> do
1254− st <- askF
1255− let contents' = runF contents st{ orgStateNotes' = [] }
1256− return $ B.note contents'
1257−
1258−noteMarker :: OrgParser String
1259−noteMarker = try $ do
1260− char '['
1261− choice [ many1Till digit (char ']')
1262− , (++) <$> string "fn:"
1263− <*> many1Till (noneOf "\n\r\t ") (char ']')
1264− ]
1265−
1266−linkOrImage :: OrgParser (F Inlines)
1267−linkOrImage = explicitOrImageLink
1268− <|> selflinkOrImage
1269− <|> angleLink
1270− <|> plainLink
1271− <?> "link or image"
1272−
1273−explicitOrImageLink :: OrgParser (F Inlines)
1274−explicitOrImageLink = try $ do
1275− char '['
1276− srcF <- applyCustomLinkFormat =<< possiblyEmptyLinkTarget
1277− title <- enclosedRaw (char '[') (char ']')
1278− title' <- parseFromString (mconcat <$> many inline) title
1279− char ']'
1280− return $ do
1281− src <- srcF
1282− if isImageFilename title
1283− then pure $ B.link src "" $ B.image title mempty mempty
1284− else linkToInlinesF src =<< title'
1285−
1286−selflinkOrImage :: OrgParser (F Inlines)
1287−selflinkOrImage = try $ do
1288− src <- char '[' *> linkTarget <* char ']'
1289− return $ linkToInlinesF src (B.str src)
1290−
1291−plainLink :: OrgParser (F Inlines)
1292−plainLink = try $ do
1293− (orig, src) <- uri
1294− returnF $ B.link src "" (B.str orig)
1295−
1296−angleLink :: OrgParser (F Inlines)
1297−angleLink = try $ do
1298− char '<'
1299− link <- plainLink
1300− char '>'
1301− return link
1302−
1303−selfTarget :: OrgParser String
1304−selfTarget = try $ char '[' *> linkTarget <* char ']'
1305−
1306−linkTarget :: OrgParser String
1307−linkTarget = enclosedByPair '[' ']' (noneOf "\n\r[]")
1308−
1309−possiblyEmptyLinkTarget :: OrgParser String
1310−possiblyEmptyLinkTarget = try linkTarget <|> ("" <$ string "[]")
1311−
1312−applyCustomLinkFormat :: String -> OrgParser (F String)
1313−applyCustomLinkFormat link = do
1314− let (linkType, rest) = break (== ':') link
1315− return $ do
1316− formatter <- M.lookup linkType <$> asksF orgStateLinkFormatters
1317− return $ maybe link ($ drop 1 rest) formatter
1318−
1319−-- | Take a link and return a function which produces new inlines when given
1320−-- description inlines.
1321−linkToInlinesF :: String -> Inlines -> F Inlines
1322−linkToInlinesF linkStr =
1323− case linkStr of
1324− "" -> pure . B.link mempty "" -- wiki link (empty by convention)
1325− ('#':_) -> pure . B.link linkStr "" -- document-local fraction
1326− _ -> case cleanLinkString linkStr of
1327− (Just cleanedLink) -> if isImageFilename cleanedLink
1328− then const . pure $ B.image cleanedLink "" ""
1329− else pure . B.link cleanedLink ""
1330− Nothing -> internalLink linkStr -- other internal link
1331−
1332−-- | Cleanup and canonicalize a string describing a link. Return @Nothing@ if
1333−-- the string does not appear to be a link.
1334−cleanLinkString :: String -> Maybe String
1335−cleanLinkString s =
1336− case s of
1337− '/':_ -> Just $ "file://" ++ s -- absolute path
1338− '.':'/':_ -> Just s -- relative path
1339− '.':'.':'/':_ -> Just s -- relative path
1340− -- Relative path or URL (file schema)
1341− 'f':'i':'l':'e':':':s' -> Just $ if ("//" `isPrefixOf` s') then s else s'
1342− _ | isUrl s -> Just s -- URL
1343− _ -> Nothing
1344− where
1345− isUrl :: String -> Bool
1346− isUrl cs =
1347− let (scheme, path) = break (== ':') cs
1348− in all (\c -> isAlphaNum c || c `elem` (".-"::String)) scheme
1349− && not (null path)
1350−
1351−isImageFilename :: String -> Bool
1352−isImageFilename filename =
1353− any (\x -> ('.':x) `isSuffixOf` filename) imageExtensions &&
1354− (any (\x -> (x++":") `isPrefixOf` filename) protocols ||
1355− ':' `notElem` filename)
1356− where
1357− imageExtensions = [ "jpeg" , "jpg" , "png" , "gif" , "svg" ]
1358− protocols = [ "file", "http", "https" ]
1359−
1360−internalLink :: String -> Inlines -> F Inlines
1361−internalLink link title = do
1362− anchorB <- (link `elem`) <$> asksF orgStateAnchorIds
1363− if anchorB
1364− then return $ B.link ('#':link) "" title
1365− else return $ B.emph title
1366−
1367−-- | Parse an anchor like @<<anchor-id>>@ and return an empty span with
1368−-- @anchor-id@ set as id. Legal anchors in org-mode are defined through
1369−-- @org-target-regexp@, which is fairly liberal. Since no link is created if
1370−-- @anchor-id@ contains spaces, we are more restrictive in what is accepted as
1371−-- an anchor.
1372−
1373−anchor :: OrgParser (F Inlines)
1374−anchor = try $ do
1375− anchorId <- parseAnchor
1376− recordAnchorId anchorId
1377− returnF $ B.spanWith (solidify anchorId, [], []) mempty
1378− where
1379− parseAnchor = string "<<"
1380− *> many1 (noneOf "\t\n\r<>\"' ")
1381− <* string ">>"
1382− <* skipSpaces
1383−
1384−-- | Replace every char but [a-zA-Z0-9_.-:] with a hypen '-'. This mirrors
1385−-- the org function @org-export-solidify-link-text@.
1386−
1387−solidify :: String -> String
1388−solidify = map replaceSpecialChar
1389− where replaceSpecialChar c
1390− | isAlphaNum c = c
1391− | c `elem` ("_.-:" :: String) = c
1392− | otherwise = '-'
1393−
1394−-- | Parses an inline code block and marks it as an babel block.
1395−inlineCodeBlock :: OrgParser (F Inlines)
1396−inlineCodeBlock = try $ do
1397− string "src_"
1398− lang <- many1 orgArgWordChar
1399− opts <- option [] $ enclosedByPair '[' ']' inlineBlockOption
1400− inlineCode <- enclosedByPair '{' '}' (noneOf "\n\r")
1401− let attrClasses = [translateLang lang, rundocBlockClass]
1402− let attrKeyVal = map toRundocAttrib (("language", lang) : opts)
1403− returnF $ B.codeWith ("", attrClasses, attrKeyVal) inlineCode
1404−
1405−enclosedByPair :: Char -- ^ opening char
1406− -> Char -- ^ closing char
1407− -> OrgParser a -- ^ parser
1408− -> OrgParser [a]
1409−enclosedByPair s e p = char s *> many1Till p (char e)
1410−
1411−emph :: OrgParser (F Inlines)
1412−emph = fmap B.emph <$> emphasisBetween '/'
1413−
1414−strong :: OrgParser (F Inlines)
1415−strong = fmap B.strong <$> emphasisBetween '*'
1416−
1417−strikeout :: OrgParser (F Inlines)
1418−strikeout = fmap B.strikeout <$> emphasisBetween '+'
1419−
1420−-- There is no underline, so we use strong instead.
1421−underline :: OrgParser (F Inlines)
1422−underline = fmap B.strong <$> emphasisBetween '_'
1423−
1424−verbatim :: OrgParser (F Inlines)
1425−verbatim = return . B.code <$> verbatimBetween '='
1426−
1427−code :: OrgParser (F Inlines)
1428−code = return . B.code <$> verbatimBetween '~'
1429−
1430−subscript :: OrgParser (F Inlines)
1431−subscript = fmap B.subscript <$> try (char '_' *> subOrSuperExpr)
1432−
1433−superscript :: OrgParser (F Inlines)
1434−superscript = fmap B.superscript <$> try (char '^' *> subOrSuperExpr)
1435−
1436−math :: OrgParser (F Inlines)
1437−math = return . B.math <$> choice [ math1CharBetween '$'
1438− , mathStringBetween '$'
1439− , rawMathBetween "\\(" "\\)"
1440− ]
1441−
1442−displayMath :: OrgParser (F Inlines)
1443−displayMath = return . B.displayMath <$> choice [ rawMathBetween "\\[" "\\]"
1444− , rawMathBetween "$$" "$$"
1445− ]
1446−
1447−updatePositions :: Char
1448− -> OrgParser (Char)
1449−updatePositions c = do
1450− when (c `elem` emphasisPreChars) updateLastPreCharPos
1451− when (c `elem` emphasisForbiddenBorderChars) updateLastForbiddenCharPos
1452− return c
1453−
1454−symbol :: OrgParser (F Inlines)
1455−symbol = return . B.str . (: "") <$> (oneOf specialChars >>= updatePositions)
1456−
1457−emphasisBetween :: Char
1458− -> OrgParser (F Inlines)
1459−emphasisBetween c = try $ do
1460− startEmphasisNewlinesCounting emphasisAllowedNewlines
1461− res <- enclosedInlines (emphasisStart c) (emphasisEnd c)
1462− isTopLevelEmphasis <- null . orgStateEmphasisCharStack <$> getState
1463− when isTopLevelEmphasis
1464− resetEmphasisNewlines
1465− return res
1466−
1467−verbatimBetween :: Char
1468− -> OrgParser String
1469−verbatimBetween c = try $
1470− emphasisStart c *>
1471− many1TillNOrLessNewlines 1 (noneOf "\n\r") (emphasisEnd c)
1472−
1473−-- | Parses a raw string delimited by @c@ using Org's math rules
1474−mathStringBetween :: Char
1475− -> OrgParser String
1476−mathStringBetween c = try $ do
1477− mathStart c
1478− body <- many1TillNOrLessNewlines mathAllowedNewlines
1479− (noneOf (c:"\n\r"))
1480− (lookAhead $ mathEnd c)
1481− final <- mathEnd c
1482− return $ body ++ [final]
1483−
1484−-- | Parse a single character between @c@ using math rules
1485−math1CharBetween :: Char
1486− -> OrgParser String
1487−math1CharBetween c = try $ do
1488− char c
1489− res <- noneOf $ c:mathForbiddenBorderChars
1490− char c
1491− eof <|> () <$ lookAhead (oneOf mathPostChars)
1492− return [res]
1493−
1494−rawMathBetween :: String
1495− -> String
1496− -> OrgParser String
1497−rawMathBetween s e = try $ string s *> manyTill anyChar (try $ string e)
1498−
1499−-- | Parses the start (opening character) of emphasis
1500−emphasisStart :: Char -> OrgParser Char
1501−emphasisStart c = try $ do
1502− guard =<< afterEmphasisPreChar
1503− guard =<< notAfterString
1504− char c
1505− lookAhead (noneOf emphasisForbiddenBorderChars)
1506− pushToInlineCharStack c
1507− return c
1508−
1509−-- | Parses the closing character of emphasis
1510−emphasisEnd :: Char -> OrgParser Char
1511−emphasisEnd c = try $ do
1512− guard =<< notAfterForbiddenBorderChar
1513− char c
1514− eof <|> () <$ lookAhead acceptablePostChars
1515− updateLastStrPos
1516− popInlineCharStack
1517− return c
1518− where acceptablePostChars =
1519− surroundingEmphasisChar >>= \x -> oneOf (x ++ emphasisPostChars)
1520−
1521−mathStart :: Char -> OrgParser Char
1522−mathStart c = try $
1523− char c <* notFollowedBy' (oneOf (c:mathForbiddenBorderChars))
1524−
1525−mathEnd :: Char -> OrgParser Char
1526−mathEnd c = try $ do
1527− res <- noneOf (c:mathForbiddenBorderChars)
1528− char c
1529− eof <|> () <$ lookAhead (oneOf mathPostChars)
1530− return res
1531−
1532−
1533−enclosedInlines :: OrgParser a
1534− -> OrgParser b
1535− -> OrgParser (F Inlines)
1536−enclosedInlines start end = try $
1537− trimInlinesF . mconcat <$> enclosed start end inline
1538−
1539−enclosedRaw :: OrgParser a
1540− -> OrgParser b
1541− -> OrgParser String
1542−enclosedRaw start end = try $
1543− start *> (onSingleLine <|> spanningTwoLines)
1544− where onSingleLine = try $ many1Till (noneOf "\n\r") end
1545− spanningTwoLines = try $
1546− anyLine >>= \f -> mappend (f <> " ") <$> onSingleLine
1547−
1548−-- | Like many1Till, but parses at most @n+1@ lines. @p@ must not consume
1549−-- newlines.
1550−many1TillNOrLessNewlines :: Int
1551− -> OrgParser Char
1552− -> OrgParser a
1553− -> OrgParser String
1554−many1TillNOrLessNewlines n p end = try $
1555− nMoreLines (Just n) mempty >>= oneOrMore
1556− where
1557− nMoreLines Nothing cs = return cs
1558− nMoreLines (Just 0) cs = try $ (cs ++) <$> finalLine
1559− nMoreLines k cs = try $ (final k cs <|> rest k cs)
1560− >>= uncurry nMoreLines
1561− final _ cs = (\x -> (Nothing, cs ++ x)) <$> try finalLine
1562− rest m cs = (\x -> (minus1 <$> m, cs ++ x ++ "\n")) <$> try (manyTill p P.newline)
1563− finalLine = try $ manyTill p end
1564− minus1 k = k - 1
1565− oneOrMore cs = guard (not $ null cs) *> return cs
1566−
1567−-- Org allows customization of the way it reads emphasis. We use the defaults
1568−-- here (see, e.g., the Emacs Lisp variable `org-emphasis-regexp-components`
1569−-- for details).
1570−
1571−-- | Chars allowed to occur before emphasis (spaces and newlines are ok, too)
1572−emphasisPreChars :: [Char]
1573−emphasisPreChars = "\t \"'({"
1574−
1575−-- | Chars allowed at after emphasis
1576−emphasisPostChars :: [Char]
1577−emphasisPostChars = "\t\n !\"'),-.:;?\\}"
1578−
1579−-- | Chars not allowed at the (inner) border of emphasis
1580−emphasisForbiddenBorderChars :: [Char]
1581−emphasisForbiddenBorderChars = "\t\n\r \"',"
1582−
1583−-- | The maximum number of newlines within
1584−emphasisAllowedNewlines :: Int
1585−emphasisAllowedNewlines = 1
1586−
1587−-- LaTeX-style math: see `org-latex-regexps` for details
1588−
1589−-- | Chars allowed after an inline ($...$) math statement
1590−mathPostChars :: [Char]
1591−mathPostChars = "\t\n \"'),-.:;?"
1592−
1593−-- | Chars not allowed at the (inner) border of math
1594−mathForbiddenBorderChars :: [Char]
1595−mathForbiddenBorderChars = "\t\n\r ,;.$"
1596−
1597−-- | Maximum number of newlines in an inline math statement
1598−mathAllowedNewlines :: Int
1599−mathAllowedNewlines = 2
1600−
1601−-- | Whether we are right behind a char allowed before emphasis
1602−afterEmphasisPreChar :: OrgParser Bool
1603−afterEmphasisPreChar = do
1604− pos <- getPosition
1605− lastPrePos <- orgStateLastPreCharPos <$> getState
1606− return . fromMaybe True $ (== pos) <$> lastPrePos
1607−
1608−-- | Whether the parser is right after a forbidden border char
1609−notAfterForbiddenBorderChar :: OrgParser Bool
1610−notAfterForbiddenBorderChar = do
1611− pos <- getPosition
1612− lastFBCPos <- orgStateLastForbiddenCharPos <$> getState
1613− return $ lastFBCPos /= Just pos
1614−
1615−-- | Read a sub- or superscript expression
1616−subOrSuperExpr :: OrgParser (F Inlines)
1617−subOrSuperExpr = try $
1618− choice [ id <$> charsInBalanced '{' '}' (noneOf "\n\r")
1619− , enclosing ('(', ')') <$> charsInBalanced '(' ')' (noneOf "\n\r")
1620− , simpleSubOrSuperString
1621− ] >>= parseFromString (mconcat <$> many inline)
1622− where enclosing (left, right) s = left : s ++ [right]
1623−
1624−simpleSubOrSuperString :: OrgParser String
1625−simpleSubOrSuperString = try $ do
1626− state <- getState
1627− guard . exportSubSuperscripts . orgStateExportSettings $ state
1628− choice [ string "*"
1629− , mappend <$> option [] ((:[]) <$> oneOf "+-")
1630− <*> many1 alphaNum
1631− ]
1632−
1633−inlineLaTeX :: OrgParser (F Inlines)
1634−inlineLaTeX = try $ do
1635− cmd <- inlineLaTeXCommand
1636− maybe mzero returnF $
1637− parseAsMath cmd `mplus` parseAsMathMLSym cmd `mplus` parseAsInlineLaTeX cmd
1638− where
1639− parseAsMath :: String -> Maybe Inlines
1640− parseAsMath cs = B.fromList <$> texMathToPandoc cs
1641−
1642− parseAsInlineLaTeX :: String -> Maybe Inlines
1643− parseAsInlineLaTeX cs = maybeRight $ runParser inlineCommand state "" cs
1644−
1645− parseAsMathMLSym :: String -> Maybe Inlines
1646− parseAsMathMLSym cs = B.str <$> MathMLEntityMap.getUnicode (clean cs)
1647− -- drop initial backslash and any trailing "{}"
1648− where clean = dropWhileEnd (`elem` ("{}" :: String)) . drop 1
1649−
1650− state :: ParserState
1651− state = def{ stateOptions = def{ readerParseRaw = True }}
1652−
1653− texMathToPandoc :: String -> Maybe [Inline]
1654− texMathToPandoc cs = (maybeRight $ readTeX cs) >>= writePandoc DisplayInline
1655−
1656−maybeRight :: Either a b -> Maybe b
1657−maybeRight = either (const Nothing) Just
1658−
1659−inlineLaTeXCommand :: OrgParser String
1660−inlineLaTeXCommand = try $ do
1661− rest <- getInput
1662− case runParser rawLaTeXInline def "source" rest of
1663− Right (RawInline _ cs) -> do
1664− -- drop any trailing whitespace, those are not be part of the command as
1665− -- far as org mode is concerned.
1666− let cmdNoSpc = dropWhileEnd isSpace cs
1667− let len = length cmdNoSpc
1668− count len anyChar
1669− return cmdNoSpc
1670− _ -> mzero
1671−
1672−-- Taken from Data.OldList.
1673−dropWhileEnd :: (a -> Bool) -> [a] -> [a]
1674−dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
1675−
1676−smart :: OrgParser (F Inlines)
1677−smart = do
1678− getOption readerSmart >>= guard
1679− doubleQuoted <|> singleQuoted <|>
1680− choice (map (return <$>) [orgApostrophe, orgDash, orgEllipses])
1681− where
1682− orgDash = dash <* updatePositions '-'
1683− orgEllipses = ellipses <* updatePositions '.'
1684− orgApostrophe =
1685− (char '\'' <|> char '\8217') <* updateLastPreCharPos
1686− <* updateLastForbiddenCharPos
1687− *> return (B.str "\x2019")
1688−
1689−singleQuoted :: OrgParser (F Inlines)
1690−singleQuoted = try $ do
1691− singleQuoteStart
1692− updatePositions '\''
1693− withQuoteContext InSingleQuote $
1694− fmap B.singleQuoted . trimInlinesF . mconcat <$>
1695− many1Till inline (singleQuoteEnd <* updatePositions '\'')
1696−
1697−-- doubleQuoted will handle regular double-quoted sections, as well
1698−-- as dialogues with an open double-quote without a close double-quote
1699−-- in the same paragraph.
1700−doubleQuoted :: OrgParser (F Inlines)
1701−doubleQuoted = try $ do
1702− doubleQuoteStart
1703− updatePositions '"'
1704− contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline)
1705− (withQuoteContext InDoubleQuote $ (doubleQuoteEnd <* updateLastForbiddenCharPos) >> return
1706− (fmap B.doubleQuoted . trimInlinesF $ contents))
1707− <|> (return $ return (B.str "\8220") <> contents)