{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {- Copyright (C) 2014 Albert Krewinkel <tarleb@moltkeplatz.de> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Readers.Org Copyright : Copyright (C) 2014 Albert Krewinkel License : GNU GPL, version 2 or above Maintainer : Albert Krewinkel <tarleb@moltkeplatz.de> Conversion of org-mode formatted plain text to 'Pandoc' document. -} module Text.Pandoc.Readers.Org ( readOrg ) where import qualified Text.Pandoc.Builder as B import Text.Pandoc.Builder ( Inlines, Blocks, HasMeta(..), (<>) , trimInlines ) import Text.Pandoc.Definition import Text.Pandoc.Options import qualified Text.Pandoc.Parsing as P import Text.Pandoc.Parsing hiding ( newline, orderedListMarker , parseFromString, blanklines ) import Text.Pandoc.Readers.LaTeX (inlineCommand, rawLaTeXInline) import Text.Pandoc.Shared (compactify', compactify'DL) import Text.TeXMath (readTeX, writePandoc, DisplayType(..)) import qualified Text.TeXMath.Readers.MathML.EntityMap as MathMLEntityMap import Control.Applicative ( pure , (<$>), (<$), (<*>), (<*), (*>) ) import Control.Arrow (first) import Control.Monad (guard, mplus, mzero, when) import Control.Monad.Reader (Reader, runReader, asks, local) import Data.Char (isAlphaNum, toLower) import Data.Default import Data.List (intersperse, isPrefixOf, isSuffixOf, foldl') import qualified Data.Map as M import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mconcat, mempty, mappend) import Network.HTTP (urlEncode) import Text.Pandoc.Error -- | Parse org-mode string and return a Pandoc document. readOrg :: ReaderOptions -- ^ Reader options -> String -- ^ String to parse (assuming @'\n'@ line endings) -> Either PandocError Pandoc readOrg opts s = runOrg opts s parseOrg data OrgParserLocal = OrgParserLocal { orgLocalQuoteContext :: QuoteContext , finalState :: OrgParserState } type OrgParser = ParserT [Char] OrgParserState (Reader OrgParserLocal) runOrg :: ReaderOptions -> String -> OrgParser a -> Either PandocError a runOrg opts inp p = fst <$> res where imd = readWithM (returnState p) def{ orgStateOptions = opts } (inp ++ "\n\n") res = runReader imd def { finalState = s } s :: OrgParserState s = either def snd res parseOrg :: OrgParser Pandoc parseOrg = do blocks' <- parseBlocks st <- getState let meta = orgStateMeta st let removeUnwantedBlocks = dropCommentTrees . filter (/= Null) return $ Pandoc meta $ removeUnwantedBlocks (B.toList $ blocks') -- | Drop COMMENT headers and the document tree below those headers. dropCommentTrees :: [Block] -> [Block] dropCommentTrees [] = [] dropCommentTrees blks@(b:bs) = maybe blks (flip dropUntilHeaderAboveLevel bs) $ commentHeaderLevel b -- | Return the level of a header starting a comment tree and Nothing -- otherwise. commentHeaderLevel :: Block -> Maybe Int commentHeaderLevel blk = case blk of (Header level _ ((Str "COMMENT"):_)) -> Just level _ -> Nothing -- | Drop blocks until a header on or above the given level is seen dropUntilHeaderAboveLevel :: Int -> [Block] -> [Block] dropUntilHeaderAboveLevel n = dropWhile (not . isHeaderLevelLowerEq n) isHeaderLevelLowerEq :: Int -> Block -> Bool isHeaderLevelLowerEq n blk = case blk of (Header level _ _) -> n >= level _ -> False -- -- Parser State for Org -- type OrgNoteRecord = (String, Blocks) type OrgNoteTable = [OrgNoteRecord] type OrgBlockAttributes = M.Map String String type OrgLinkFormatters = M.Map String (String -> String) -- | Org-mode parser state data OrgParserState = OrgParserState { orgStateOptions :: ReaderOptions , orgStateAnchorIds :: [String] , orgStateBlockAttributes :: OrgBlockAttributes , orgStateEmphasisCharStack :: [Char] , orgStateEmphasisNewlines :: Maybe Int , orgStateLastForbiddenCharPos :: Maybe SourcePos , orgStateLastPreCharPos :: Maybe SourcePos , orgStateLastStrPos :: Maybe SourcePos , orgStateLinkFormatters :: OrgLinkFormatters , orgStateMeta :: Meta , orgStateNotes' :: OrgNoteTable } instance Default OrgParserLocal where def = OrgParserLocal NoQuote def instance HasReaderOptions OrgParserState where extractReaderOptions = orgStateOptions instance HasMeta OrgParserState where setMeta field val st = st{ orgStateMeta = setMeta field val $ orgStateMeta st } deleteMeta field st = st{ orgStateMeta = deleteMeta field $ orgStateMeta st } instance HasLastStrPosition OrgParserState where getLastStrPos = orgStateLastStrPos setLastStrPos pos st = st{ orgStateLastStrPos = Just pos } instance HasQuoteContext st (Reader OrgParserLocal) where getQuoteContext = asks orgLocalQuoteContext withQuoteContext q = local (\s -> s{orgLocalQuoteContext = q}) instance Default OrgParserState where def = defaultOrgParserState defaultOrgParserState :: OrgParserState defaultOrgParserState = OrgParserState { orgStateOptions = def , orgStateAnchorIds = [] , orgStateBlockAttributes = M.empty , orgStateEmphasisCharStack = [] , orgStateEmphasisNewlines = Nothing , orgStateLastForbiddenCharPos = Nothing , orgStateLastPreCharPos = Nothing , orgStateLastStrPos = Nothing , orgStateLinkFormatters = M.empty , orgStateMeta = nullMeta , orgStateNotes' = [] } recordAnchorId :: String -> OrgParser () recordAnchorId i = updateState $ \s -> let as = orgStateAnchorIds s in s{ orgStateAnchorIds = i : as } addBlockAttribute :: String -> String -> OrgParser () addBlockAttribute key val = updateState $ \s -> let attrs = orgStateBlockAttributes s in s{ orgStateBlockAttributes = M.insert key val attrs } lookupBlockAttribute :: String -> OrgParser (Maybe String) lookupBlockAttribute key = M.lookup key . orgStateBlockAttributes <$> getState resetBlockAttributes :: OrgParser () resetBlockAttributes = updateState $ \s -> s{ orgStateBlockAttributes = orgStateBlockAttributes def } updateLastForbiddenCharPos :: OrgParser () updateLastForbiddenCharPos = getPosition >>= \p -> updateState $ \s -> s{ orgStateLastForbiddenCharPos = Just p} updateLastPreCharPos :: OrgParser () updateLastPreCharPos = getPosition >>= \p -> updateState $ \s -> s{ orgStateLastPreCharPos = Just p} pushToInlineCharStack :: Char -> OrgParser () pushToInlineCharStack c = updateState $ \s -> s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s } popInlineCharStack :: OrgParser () popInlineCharStack = updateState $ \s -> s{ orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ s } surroundingEmphasisChar :: OrgParser [Char] surroundingEmphasisChar = take 1 . drop 1 . orgStateEmphasisCharStack <$> getState startEmphasisNewlinesCounting :: Int -> OrgParser () startEmphasisNewlinesCounting maxNewlines = updateState $ \s -> s{ orgStateEmphasisNewlines = Just maxNewlines } decEmphasisNewlinesCount :: OrgParser () decEmphasisNewlinesCount = updateState $ \s -> s{ orgStateEmphasisNewlines = (\n -> n - 1) <$> orgStateEmphasisNewlines s } newlinesCountWithinLimits :: OrgParser Bool newlinesCountWithinLimits = do st <- getState return $ ((< 0) <$> orgStateEmphasisNewlines st) /= Just True resetEmphasisNewlines :: OrgParser () resetEmphasisNewlines = updateState $ \s -> s{ orgStateEmphasisNewlines = Nothing } addLinkFormat :: String -> (String -> String) -> OrgParser () addLinkFormat key formatter = updateState $ \s -> let fs = orgStateLinkFormatters s in s{ orgStateLinkFormatters = M.insert key formatter fs } addToNotesTable :: OrgNoteRecord -> OrgParser () addToNotesTable note = do oldnotes <- orgStateNotes' <$> getState updateState $ \s -> s{ orgStateNotes' = note:oldnotes } -- The version Text.Pandoc.Parsing cannot be used, as we need additional parts -- of the state saved and restored. parseFromString :: OrgParser a -> String -> OrgParser a parseFromString parser str' = do oldLastPreCharPos <- orgStateLastPreCharPos <$> getState updateState $ \s -> s{ orgStateLastPreCharPos = Nothing } result <- P.parseFromString parser str' updateState $ \s -> s{ orgStateLastPreCharPos = oldLastPreCharPos } return result -- -- Adaptions and specializations of parsing utilities -- -- | Like @Text.Parsec.Char.newline@, but causes additional state changes. newline :: OrgParser Char newline = P.newline <* updateLastPreCharPos <* updateLastForbiddenCharPos -- | Like @Text.Parsec.Char.blanklines@, but causes additional state changes. blanklines :: OrgParser [Char] blanklines = P.blanklines <* updateLastPreCharPos <* updateLastForbiddenCharPos -- -- parsing blocks -- parseBlocks :: OrgParser Blocks parseBlocks = mconcat <$> manyTill block eof block :: OrgParser Blocks block = choice [ mempty <$ blanklines , optionalAttributes $ choice [ orgBlock , figure , table ] , example , drawer , specialLine , header , hline , list , latexFragment , noteBlock , paraOrPlain ] <?> "block" optionalAttributes :: OrgParser Blocks -> OrgParser Blocks optionalAttributes parser = try $ resetBlockAttributes *> parseBlockAttributes *> parser parseBlockAttributes :: OrgParser () parseBlockAttributes = do attrs <- many attribute mapM_ (uncurry parseAndAddAttribute) attrs where attribute :: OrgParser (String, String) attribute = try $ do key <- metaLineStart *> many1Till nonspaceChar (char ':') val <- skipSpaces *> anyLine return (map toLower key, val) parseAndAddAttribute :: String -> String -> OrgParser () parseAndAddAttribute key value = do let key' = map toLower key () <$ addBlockAttribute key' value lookupInlinesAttr :: String -> OrgParser (Maybe Inlines) lookupInlinesAttr attr = try $ do val <- lookupBlockAttribute attr maybe (return Nothing) (fmap Just . parseFromString parseInlines) val -- -- Org Blocks (#+BEGIN_... / #+END_...) -- type BlockProperties = (Int, String) -- (Indentation, Block-Type) orgBlock :: OrgParser Blocks orgBlock = try $ do blockProp@(_, blkType) <- blockHeaderStart ($ blockProp) $ case blkType of "comment" -> withRaw' (const mempty) "html" -> withRaw' (B.rawBlock blkType) "latex" -> withRaw' (B.rawBlock blkType) "ascii" -> withRaw' (B.rawBlock blkType) "example" -> withRaw' exampleCode "quote" -> withParsed B.blockQuote "verse" -> verseBlock "src" -> codeBlock _ -> withParsed (divWithClass blkType) blockHeaderStart :: OrgParser (Int, String) blockHeaderStart = try $ (,) <$> indent <*> blockType where indent = length <$> many spaceChar blockType = map toLower <$> (stringAnyCase "#+begin_" *> orgArgWord) withRaw' :: (String -> Blocks) -> BlockProperties -> OrgParser Blocks withRaw' f blockProp = (ignHeaders *> (f <$> rawBlockContent blockProp)) withParsed :: (Blocks -> Blocks) -> BlockProperties -> OrgParser Blocks withParsed f blockProp = (ignHeaders *> (f <$> parsedBlockContent blockProp)) ignHeaders :: OrgParser () ignHeaders = (() <$ newline) <|> (() <$ anyLine) divWithClass :: String -> Blocks -> Blocks divWithClass cls = B.divWith ("", [cls], []) verseBlock :: BlockProperties -> OrgParser Blocks verseBlock blkProp = try $ do ignHeaders content <- rawBlockContent blkProp B.para . mconcat . intersperse B.linebreak <$> mapM (parseFromString parseInlines) (lines content) exportsCode :: [(String, String)] -> Bool exportsCode attrs = not (("rundoc-exports", "none") `elem` attrs || ("rundoc-exports", "results") `elem` attrs) exportsResults :: [(String, String)] -> Bool exportsResults attrs = ("rundoc-exports", "results") `elem` attrs || ("rundoc-exports", "both") `elem` attrs followingResultsBlock :: OrgParser (Maybe String) followingResultsBlock = optionMaybe (try $ blanklines *> stringAnyCase "#+RESULTS:" *> blankline *> (unlines <$> many1 exampleLine)) codeBlock :: BlockProperties -> OrgParser Blocks codeBlock blkProp = do skipSpaces (classes, kv) <- codeHeaderArgs <|> (mempty <$ ignHeaders) id' <- fromMaybe "" <$> lookupBlockAttribute "name" content <- rawBlockContent blkProp resultsContent <- followingResultsBlock let includeCode = exportsCode kv let includeResults = exportsResults kv let codeBlck = B.codeBlockWith ( id', classes, kv ) content labelledBlck <- maybe codeBlck (labelDiv codeBlck) <$> lookupInlinesAttr "caption" let resultBlck = maybe mempty exampleCode resultsContent return $ (if includeCode then labelledBlck else mempty) <> (if includeResults then resultBlck else mempty) where labelDiv blk value = B.divWith nullAttr (labelledBlock value <> blk) labelledBlock = B.plain . B.spanWith ("", ["label"], []) rawBlockContent :: BlockProperties -> OrgParser String rawBlockContent (indent, blockType) = try $ unlines . map commaEscaped <$> manyTill indentedLine blockEnder where indentedLine = try $ ("" <$ blankline) <|> (indentWith indent *> anyLine) blockEnder = try $ indentWith indent *> stringAnyCase ("#+end_" <> blockType) parsedBlockContent :: BlockProperties -> OrgParser Blocks parsedBlockContent blkProps = try $ do raw <- rawBlockContent blkProps parseFromString parseBlocks (raw ++ "\n") -- indent by specified number of spaces (or equiv. tabs) indentWith :: Int -> OrgParser String indentWith num = do tabStop <- getOption readerTabStop if num < tabStop then count num (char ' ') else choice [ try (count num (char ' ')) , try (char '\t' >> count (num - tabStop) (char ' ')) ] type SwitchOption = (Char, Maybe String) orgArgWord :: OrgParser String orgArgWord = many1 orgArgWordChar -- | Parse code block arguments -- TODO: We currently don't handle switches. codeHeaderArgs :: OrgParser ([String], [(String, String)]) codeHeaderArgs = try $ do language <- skipSpaces *> orgArgWord _ <- skipSpaces *> (try $ switch `sepBy` (many1 spaceChar)) parameters <- manyTill blockOption newline let pandocLang = translateLang language return $ if hasRundocParameters parameters then ( [ pandocLang, rundocBlockClass ] , map toRundocAttrib (("language", language) : parameters) ) else ([ pandocLang ], parameters) where hasRundocParameters = not . null switch :: OrgParser SwitchOption switch = try $ simpleSwitch <|> lineNumbersSwitch where simpleSwitch = (\c -> (c, Nothing)) <$> (oneOf "-+" *> letter) lineNumbersSwitch = (\ls -> ('l', Just ls)) <$> (string "-l \"" *> many1Till nonspaceChar (char '"')) translateLang :: String -> String translateLang "C" = "c" translateLang "C++" = "cpp" translateLang "emacs-lisp" = "commonlisp" -- emacs lisp is not supported translateLang "js" = "javascript" translateLang "lisp" = "commonlisp" translateLang "R" = "r" translateLang "sh" = "bash" translateLang "sqlite" = "sql" translateLang cs = cs -- | Prefix used for Rundoc classes and arguments. rundocPrefix :: String rundocPrefix = "rundoc-" -- | The class-name used to mark rundoc blocks. rundocBlockClass :: String rundocBlockClass = rundocPrefix ++ "block" blockOption :: OrgParser (String, String) blockOption = try $ (,) <$> orgArgKey <*> orgParamValue inlineBlockOption :: OrgParser (String, String) inlineBlockOption = try $ (,) <$> orgArgKey <*> orgInlineParamValue orgArgKey :: OrgParser String orgArgKey = try $ skipSpaces *> char ':' *> many1 orgArgWordChar orgParamValue :: OrgParser String orgParamValue = try $ skipSpaces *> many1 (noneOf "\t\n\r ") <* skipSpaces orgInlineParamValue :: OrgParser String orgInlineParamValue = try $ skipSpaces *> many1 (noneOf "\t\n\r ]") <* skipSpaces orgArgWordChar :: OrgParser Char orgArgWordChar = alphaNum <|> oneOf "-_" toRundocAttrib :: (String, String) -> (String, String) toRundocAttrib = first ("rundoc-" ++) commaEscaped :: String -> String commaEscaped (',':cs@('*':_)) = cs commaEscaped (',':cs@('#':'+':_)) = cs commaEscaped cs = cs example :: OrgParser Blocks example = try $ do return . exampleCode =<< unlines <$> many1 exampleLine exampleCode :: String -> Blocks exampleCode = B.codeBlockWith ("", ["example"], []) exampleLine :: OrgParser String exampleLine = try $ skipSpaces *> string ": " *> anyLine -- Drawers for properties or a logbook drawer :: OrgParser Blocks drawer = try $ do drawerStart manyTill drawerLine (try drawerEnd) return mempty drawerStart :: OrgParser String drawerStart = try $ skipSpaces *> drawerName <* skipSpaces <* P.newline where drawerName = try $ char ':' *> validDrawerName <* char ':' validDrawerName = stringAnyCase "PROPERTIES" <|> stringAnyCase "LOGBOOK" drawerLine :: OrgParser String drawerLine = try anyLine drawerEnd :: OrgParser String drawerEnd = try $ skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* P.newline -- -- Figures -- -- Figures (Image on a line by itself, preceded by name and/or caption) figure :: OrgParser Blocks figure = try $ do (cap, nam) <- nameAndCaption src <- skipSpaces *> selfTarget <* skipSpaces <* P.newline guard (isImageFilename src) return $ B.para $ B.image src nam cap where nameAndCaption = do maybeCap <- lookupInlinesAttr "caption" maybeNam <- lookupBlockAttribute "name" guard $ isJust maybeCap || isJust maybeNam return ( fromMaybe mempty maybeCap , maybe mempty withFigPrefix maybeNam ) withFigPrefix cs = if "fig:" `isPrefixOf` cs then cs else "fig:" ++ cs -- -- Comments, Options and Metadata specialLine :: OrgParser Blocks specialLine = try $ metaLine <|> commentLine metaLine :: OrgParser Blocks metaLine = try $ mempty <$ (metaLineStart *> (optionLine <|> declarationLine)) commentLine :: OrgParser Blocks commentLine = try $ commentLineStart *> anyLine *> pure mempty -- The order, in which blocks are tried, makes sure that we're not looking at -- the beginning of a block, so we don't need to check for it metaLineStart :: OrgParser String metaLineStart = try $ mappend <$> many spaceChar <*> string "#+" commentLineStart :: OrgParser String commentLineStart = try $ mappend <$> many spaceChar <*> string "# " declarationLine :: OrgParser () declarationLine = try $ do key <- metaKey inlines <- metaInlines updateState $ \st -> let meta' = B.setMeta key inlines nullMeta in st { orgStateMeta = orgStateMeta st <> meta' } return () metaInlines :: OrgParser MetaValue metaInlines = (MetaInlines . B.toList) <$> inlinesTillNewline metaKey :: OrgParser String metaKey = map toLower <$> many1 (noneOf ": \n\r") <* char ':' <* skipSpaces optionLine :: OrgParser () optionLine = try $ do key <- metaKey case key of "link" -> parseLinkFormat >>= uncurry addLinkFormat _ -> mzero parseLinkFormat :: OrgParser ((String, String -> String)) parseLinkFormat = try $ do linkType <- (:) <$> letter <*> many (alphaNum <|> oneOf "-_") <* skipSpaces linkSubst <- parseFormat return (linkType, linkSubst) -- | An ad-hoc, single-argument-only implementation of a printf-style format -- parser. parseFormat :: OrgParser (String -> String) parseFormat = try $ do replacePlain <|> replaceUrl <|> justAppend where -- inefficient, but who cares replacePlain = try $ (\x -> concat . flip intersperse x) <$> sequence [tillSpecifier 's', rest] replaceUrl = try $ (\x -> concat . flip intersperse x . urlEncode) <$> sequence [tillSpecifier 'h', rest] justAppend = try $ (++) <$> rest rest = manyTill anyChar (eof <|> () <$ oneOf "\n\r") tillSpecifier c = manyTill (noneOf "\n\r") (try $ string ('%':c:"")) -- -- Headers -- -- | Headers header :: OrgParser Blocks header = try $ do level <- headerStart title <- inlinesTillNewline return $ B.header level title headerStart :: OrgParser Int headerStart = try $ (length <$> many1 (char '*')) <* many1 (char ' ') -- Don't use (or need) the reader wrapper here, we want hline to be -- @show@able. Otherwise we can't use it with @notFollowedBy'@. -- | Horizontal Line (five -- dashes or more) hline :: OrgParser Blocks hline = try $ do skipSpaces string "-----" many (char '-') skipSpaces newline return B.horizontalRule -- -- Tables -- data OrgTableRow = OrgContentRow [Blocks] | OrgAlignRow [Alignment] | OrgHlineRow data OrgTable = OrgTable { orgTableColumns :: Int , orgTableAlignments :: [Alignment] , orgTableHeader :: [Blocks] , orgTableRows :: [[Blocks]] } table :: OrgParser Blocks table = try $ do lookAhead tableStart do rows <- tableRows (cptn :: Inlines) <- fromMaybe "" <$> lookupInlinesAttr "caption" return $ ($ cptn) . orgToPandocTable . normalizeTable . rowsToTable $ rows orgToPandocTable :: OrgTable -> Inlines -> Blocks orgToPandocTable (OrgTable _ aligns heads lns) caption = B.table caption (zip aligns $ repeat 0) heads lns tableStart :: OrgParser Char tableStart = try $ skipSpaces *> char '|' tableRows :: OrgParser [OrgTableRow] tableRows = try $ many (tableAlignRow <|> tableHline <|> tableContentRow) tableContentRow :: OrgParser OrgTableRow tableContentRow = try $ OrgContentRow <$> (tableStart *> manyTill tableContentCell newline) tableContentCell :: OrgParser Blocks tableContentCell = try $ B.plain . trimInlines . mconcat <$> many1Till inline endOfCell endOfCell :: OrgParser Char endOfCell = try $ char '|' <|> lookAhead newline tableAlignRow :: OrgParser OrgTableRow tableAlignRow = try $ OrgAlignRow <$> (tableStart *> manyTill tableAlignCell newline) tableAlignCell :: OrgParser Alignment tableAlignCell = choice [ try $ emptyCell *> return AlignDefault , try $ skipSpaces *> char '<' *> tableAlignFromChar <* many digit <* char '>' <* emptyCell ] <?> "alignment info" where emptyCell = try $ skipSpaces *> endOfCell tableAlignFromChar :: OrgParser Alignment tableAlignFromChar = try $ choice [ char 'l' *> return AlignLeft , char 'c' *> return AlignCenter , char 'r' *> return AlignRight ] tableHline :: OrgParser OrgTableRow tableHline = try $ OrgHlineRow <$ (tableStart *> char '-' *> anyLine) rowsToTable :: [OrgTableRow] -> OrgTable rowsToTable = foldl' (flip rowToContent) zeroTable where zeroTable = OrgTable 0 mempty mempty mempty normalizeTable :: OrgTable -> OrgTable normalizeTable (OrgTable cols aligns heads lns) = let aligns' = fillColumns aligns AlignDefault heads' = if heads == mempty then mempty else fillColumns heads (B.plain mempty) lns' = map (`fillColumns` B.plain mempty) lns fillColumns base padding = take cols $ base ++ repeat padding in OrgTable cols aligns' heads' lns' -- One or more horizontal rules after the first content line mark the previous -- line as a header. All other horizontal lines are discarded. rowToContent :: OrgTableRow -> OrgTable -> OrgTable rowToContent OrgHlineRow t = maybeBodyToHeader t rowToContent (OrgAlignRow as) t = setLongestRow as . setAligns as $ t rowToContent (OrgContentRow rf) t = setLongestRow rf . appendToBody rf $ t setLongestRow :: [a] -> OrgTable -> OrgTable setLongestRow rs t = t{ orgTableColumns = max (length rs) (orgTableColumns t) } maybeBodyToHeader :: OrgTable -> OrgTable maybeBodyToHeader t = case t of OrgTable{ orgTableHeader = [], orgTableRows = b:[] } -> t{ orgTableHeader = b , orgTableRows = [] } _ -> t appendToBody :: [Blocks] -> OrgTable -> OrgTable appendToBody r t = t{ orgTableRows = orgTableRows t ++ [r] } setAligns :: [Alignment] -> OrgTable -> OrgTable setAligns aligns t = t{ orgTableAlignments = aligns } -- -- LaTeX fragments -- latexFragment :: OrgParser Blocks latexFragment = try $ do envName <- latexEnvStart content <- mconcat <$> manyTill anyLineNewline (latexEnd envName) return $ B.rawBlock "latex" (content `inLatexEnv` envName) where c `inLatexEnv` e = mconcat [ "\\begin{", e, "}\n" , c , "\\end{", e, "}\n" ] latexEnvStart :: OrgParser String latexEnvStart = try $ do skipSpaces *> string "\\begin{" *> latexEnvName <* string "}" <* blankline latexEnd :: String -> OrgParser () latexEnd envName = try $ () <$ skipSpaces <* string ("\\end{" ++ envName ++ "}") <* blankline -- | Parses a LaTeX environment name. latexEnvName :: OrgParser String latexEnvName = try $ do mappend <$> many1 alphaNum <*> option "" (string "*") -- -- Footnote defintions -- noteBlock :: OrgParser Blocks noteBlock = try $ do ref <- noteMarker <* skipSpaces content <- mconcat <$> blocksTillHeaderOrNote addToNotesTable (ref, content) return mempty where blocksTillHeaderOrNote = many1Till block (eof <|> () <$ lookAhead noteMarker <|> () <$ lookAhead headerStart) -- Paragraphs or Plain text paraOrPlain :: OrgParser Blocks paraOrPlain = try $ do ils <- parseInlines nl <- option False (newline >> return True) try (guard nl >> notFollowedBy (orderedListStart <|> bulletListStart) >> (return $ B.para ils)) <|> (return $ B.plain ils) inlinesTillNewline :: OrgParser Inlines inlinesTillNewline = trimInlines . mconcat <$> manyTill inline newline -- -- list blocks -- list :: OrgParser Blocks list = choice [ definitionList, bulletList, orderedList ] <?> "list" definitionList :: OrgParser Blocks definitionList = try $ do n <- lookAhead (bulletListStart' Nothing) B.definitionList . compactify'DL <$> many1 (definitionListItem $ bulletListStart' (Just n)) bulletList :: OrgParser Blocks bulletList = try $ do n <- lookAhead (bulletListStart' Nothing) B.bulletList . compactify' <$> many1 (listItem (bulletListStart' $ Just n)) orderedList :: OrgParser Blocks orderedList = B.orderedList . compactify' <$> many1 (listItem orderedListStart) genericListStart :: OrgParser String -> OrgParser Int genericListStart listMarker = try $ (+) <$> (length <$> many spaceChar) <*> (length <$> listMarker <* many1 spaceChar) -- parses bullet list marker. maybe we know the indent level bulletListStart :: OrgParser Int bulletListStart = bulletListStart' Nothing bulletListStart' :: Maybe Int -> OrgParser Int -- returns length of bulletList prefix, inclusive of marker bulletListStart' Nothing = do ind <- length <$> many spaceChar when (ind == 0) $ notFollowedBy (char '*') oneOf bullets many1 spaceChar return (ind + 1) -- Unindented lists are legal, but they can't use '*' bullets -- We return n to maintain compatibility with the generic listItem bulletListStart' (Just n) = do count (n-1) spaceChar when (n == 1) $ notFollowedBy (char '*') oneOf bullets many1 spaceChar return n bullets :: String bullets = "*+-" orderedListStart :: OrgParser Int orderedListStart = genericListStart orderedListMarker -- Ordered list markers allowed in org-mode where orderedListMarker = mappend <$> many1 digit <*> (pure <$> oneOf ".)") definitionListItem :: OrgParser Int -> OrgParser (Inlines, [Blocks]) definitionListItem parseMarkerGetLength = try $ do markerLength <- parseMarkerGetLength term <- manyTill (noneOf "\n\r") (try $ string "::") line1 <- anyLineNewline blank <- option "" ("\n" <$ blankline) cont <- concat <$> many (listContinuation markerLength) term' <- parseFromString parseInlines term contents' <- parseFromString parseBlocks $ line1 ++ blank ++ cont return (term', [contents']) -- parse raw text for one list item, excluding start marker and continuations listItem :: OrgParser Int -> OrgParser Blocks listItem start = try $ do markerLength <- try start firstLine <- anyLineNewline blank <- option "" ("\n" <$ blankline) rest <- concat <$> many (listContinuation markerLength) parseFromString parseBlocks $ firstLine ++ blank ++ rest -- continuation of a list item - indented and separated by blankline or endline. -- Note: nested lists are parsed as continuations. listContinuation :: Int -> OrgParser String listContinuation markerLength = try $ notFollowedBy' blankline *> (mappend <$> (concat <$> many1 listLine) <*> many blankline) where listLine = try $ indentWith markerLength *> anyLineNewline anyLineNewline :: OrgParser String anyLineNewline = (++ "\n") <$> anyLine -- -- inline -- inline :: OrgParser Inlines inline = choice [ whitespace , linebreak , cite , footnote , linkOrImage , anchor , inlineCodeBlock , str , endline , emph , strong , strikeout , underline , code , math , displayMath , verbatim , subscript , superscript , inlineLaTeX , smart , symbol ] <* (guard =<< newlinesCountWithinLimits) <?> "inline" parseInlines :: OrgParser Inlines parseInlines = trimInlines . mconcat <$> many1 inline -- treat these as potentially non-text when parsing inline: specialChars :: [Char] specialChars = "\"$'()*+-,./:<=>[\\]^_{|}~" whitespace :: OrgParser Inlines whitespace = B.space <$ skipMany1 spaceChar <* updateLastPreCharPos <* updateLastForbiddenCharPos <?> "whitespace" linebreak :: OrgParser Inlines linebreak = try $ B.linebreak <$ string "\\\\" <* skipSpaces <* newline str :: OrgParser Inlines str = B.str <$> many1 (noneOf $ specialChars ++ "\n\r ") <* updateLastStrPos -- | An endline character that can be treated as a space, not a structural -- break. This should reflect the values of the Emacs variable -- @org-element-pagaraph-separate@. endline :: OrgParser Inlines endline = try $ do newline notFollowedBy blankline notFollowedBy' exampleLine notFollowedBy' hline notFollowedBy' noteMarker notFollowedBy' tableStart notFollowedBy' drawerStart notFollowedBy' headerStart notFollowedBy' metaLineStart notFollowedBy' latexEnvStart notFollowedBy' commentLineStart notFollowedBy' bulletListStart notFollowedBy' orderedListStart decEmphasisNewlinesCount guard =<< newlinesCountWithinLimits updateLastPreCharPos return $ B.space cite :: OrgParser Inlines cite = try $ do guardEnabled Ext_citations (cs, raw) <- withRaw normalCite return $ flip B.cite (B.text raw) cs normalCite :: OrgParser [Citation] normalCite = try $ char '[' *> skipSpaces *> citeList <* skipSpaces <* char ']' citeList :: OrgParser [Citation] citeList = sepBy1 citation (try $ char ';' *> skipSpaces) citation :: OrgParser Citation citation = try $ do pref <- prefix (suppress_author, key) <- citeKey suff <- suffix return $ Citation{ citationId = key , citationPrefix = B.toList pref , citationSuffix = B.toList suff , citationMode = if suppress_author then SuppressAuthor else NormalCitation , citationNoteNum = 0 , citationHash = 0 } where prefix = trimInlines . mconcat <$> manyTill inline (char ']' <|> (']' <$ lookAhead citeKey)) suffix = try $ do hasSpace <- option False (notFollowedBy nonspaceChar >> return True) skipSpaces rest <- trimInlines . mconcat <$> many (notFollowedBy (oneOf ";]") *> inline) return $ if hasSpace then B.space <> rest else rest footnote :: OrgParser Inlines footnote = try $ inlineNote <|> referencedNote inlineNote :: OrgParser Inlines inlineNote = try $ do string "[fn:" ref <- many alphaNum char ':' note <- B.para . trimInlines . mconcat <$> many1Till inline (char ']') when (not $ null ref) $ addToNotesTable ("fn:" ++ ref, note) return $ B.note note referencedNote :: OrgParser Inlines referencedNote = try $ do ref <- noteMarker notes <- asks (orgStateNotes' . finalState) return $ case lookup ref notes of Just contents -> B.note contents Nothing -> B.str $ "[" ++ ref ++ "]" noteMarker :: OrgParser String noteMarker = try $ do char '[' choice [ many1Till digit (char ']') , (++) <$> string "fn:" <*> many1Till (noneOf "\n\r\t ") (char ']') ] linkOrImage :: OrgParser Inlines linkOrImage = explicitOrImageLink <|> selflinkOrImage <|> angleLink <|> plainLink <?> "link or image" explicitOrImageLink :: OrgParser Inlines explicitOrImageLink = try $ do char '[' src <- applyCustomLinkFormat =<< possiblyEmptyLinkTarget title <- enclosedRaw (char '[') (char ']') title' <- parseFromString (mconcat <$> many inline) title char ']' alt <- internalLink src title' return $ (if isImageFilename src && isImageFilename title then B.link src "" $ B.image title mempty mempty else fromMaybe alt (linkToInlines src title')) selflinkOrImage :: OrgParser Inlines selflinkOrImage = try $ do src <- char '[' *> linkTarget <* char ']' return $ fromMaybe "" (linkToInlines src (B.str src)) plainLink :: OrgParser Inlines plainLink = try $ do (orig, src) <- uri return $ B.link src "" (B.str orig) angleLink :: OrgParser Inlines angleLink = try $ do char '<' link <- plainLink char '>' return link selfTarget :: OrgParser String selfTarget = try $ char '[' *> linkTarget <* char ']' linkTarget :: OrgParser String linkTarget = enclosedByPair '[' ']' (noneOf "\n\r[]") possiblyEmptyLinkTarget :: OrgParser String possiblyEmptyLinkTarget = try linkTarget <|> ("" <$ string "[]") applyCustomLinkFormat :: String -> OrgParser String applyCustomLinkFormat link = do let (linkType, rest) = break (== ':') link fmts <- asks finalState return $ case M.lookup linkType (orgStateLinkFormatters fmts) of Just v -> (v (drop 1 rest)) Nothing -> link -- TODO: might be a lot smarter/cleaner to use parsec and ADTs for this kind -- of parsing. linkToInlines :: String -> Inlines -> Maybe Inlines linkToInlines = \s -> case s of _ | null s -> Just . B.link "" "" _ | isAnchor s -> Just . B.link s "" _ | isImageFilename s -> const . Just $ B.image s "" "" _ | isFileLink s -> Just . B.link (dropLinkType s) "" _ | isUri s -> Just . B.link s "" _ | isAbsoluteFilePath s -> Just . B.link ("file://" ++ s) "" _ | isRelativeFilePath s -> Just . B.link s "" _ -> const Nothing isAnchor :: String -> Bool isAnchor s = "#" `isPrefixOf` s isFileLink :: String -> Bool isFileLink s = ("file:" `isPrefixOf` s) && not ("file://" `isPrefixOf` s) dropLinkType :: String -> String dropLinkType = tail . snd . break (== ':') isRelativeFilePath :: String -> Bool isRelativeFilePath s = (("./" `isPrefixOf` s) || ("../" `isPrefixOf` s)) && (':' `notElem` s) isUri :: String -> Bool isUri s = let (scheme, path) = break (== ':') s in all (\c -> isAlphaNum c || c `elem` (".-" :: String)) scheme && not (null path) isAbsoluteFilePath :: String -> Bool isAbsoluteFilePath = ('/' ==) . head isImageFilename :: String -> Bool isImageFilename filename = any (\x -> ('.':x) `isSuffixOf` filename) imageExtensions && (any (\x -> (x++":") `isPrefixOf` filename) protocols || ':' `notElem` filename) where imageExtensions = [ "jpeg" , "jpg" , "png" , "gif" , "svg" ] protocols = [ "file", "http", "https" ] internalLink :: String -> Inlines -> OrgParser Inlines internalLink link title = do anchorB <- asks finalState return $ if link `elem` (orgStateAnchorIds anchorB) then B.link ('#':link) "" title else B.emph title -- | Parse an anchor like @<<anchor-id>>@ and return an empty span with -- @anchor-id@ set as id. Legal anchors in org-mode are defined through -- @org-target-regexp@, which is fairly liberal. Since no link is created if -- @anchor-id@ contains spaces, we are more restrictive in what is accepted as -- an anchor. anchor :: OrgParser Inlines anchor = try $ do anchorId <- parseAnchor recordAnchorId anchorId return $ B.spanWith (solidify anchorId, [], []) mempty where parseAnchor = string "<<" *> many1 (noneOf "\t\n\r<>\"' ") <* string ">>" <* skipSpaces -- | Replace every char but [a-zA-Z0-9_.-:] with a hypen '-'. This mirrors -- the org function @org-export-solidify-link-text@. solidify :: String -> String solidify = map replaceSpecialChar where replaceSpecialChar c | isAlphaNum c = c | c `elem` ("_.-:" :: String) = c | otherwise = '-' -- | Parses an inline code block and marks it as an babel block. inlineCodeBlock :: OrgParser Inlines inlineCodeBlock = try $ do string "src_" lang <- many1 orgArgWordChar opts <- option [] $ enclosedByPair '[' ']' inlineBlockOption inlineCode <- enclosedByPair '{' '}' (noneOf "\n\r") let attrClasses = [translateLang lang, rundocBlockClass] let attrKeyVal = map toRundocAttrib (("language", lang) : opts) return $ B.codeWith ("", attrClasses, attrKeyVal) inlineCode enclosedByPair :: Char -- ^ opening char -> Char -- ^ closing char -> OrgParser a -- ^ parser -> OrgParser [a] enclosedByPair s e p = char s *> many1Till p (char e) emph :: OrgParser Inlines emph = B.emph <$> emphasisBetween '/' strong :: OrgParser Inlines strong = B.strong <$> emphasisBetween '*' strikeout :: OrgParser Inlines strikeout = B.strikeout <$> emphasisBetween '+' -- There is no underline, so we use strong instead. underline :: OrgParser Inlines underline = B.strong <$> emphasisBetween '_' verbatim :: OrgParser Inlines verbatim = B.code <$> verbatimBetween '=' code :: OrgParser Inlines code = B.code <$> verbatimBetween '~' subscript :: OrgParser Inlines subscript = B.subscript <$> try (char '_' *> subOrSuperExpr) superscript :: OrgParser Inlines superscript = B.superscript <$> try (char '^' *> subOrSuperExpr) math :: OrgParser Inlines math = B.math <$> choice [ math1CharBetween '$' , mathStringBetween '$' , rawMathBetween "\\(" "\\)" ] displayMath :: OrgParser Inlines displayMath = B.displayMath <$> choice [ rawMathBetween "\\[" "\\]" , rawMathBetween "$$" "$$" ] symbol :: OrgParser Inlines symbol = B.str . (: "") <$> (oneOf specialChars >>= updatePositions) where updatePositions c = do when (c `elem` emphasisPreChars) updateLastPreCharPos when (c `elem` emphasisForbiddenBorderChars) updateLastForbiddenCharPos return c emphasisBetween :: Char -> OrgParser Inlines emphasisBetween c = try $ do startEmphasisNewlinesCounting emphasisAllowedNewlines res <- enclosedInlines (emphasisStart c) (emphasisEnd c) isTopLevelEmphasis <- null . orgStateEmphasisCharStack <$> getState when isTopLevelEmphasis resetEmphasisNewlines return res verbatimBetween :: Char -> OrgParser String verbatimBetween c = try $ emphasisStart c *> many1TillNOrLessNewlines 1 (noneOf "\n\r") (emphasisEnd c) -- | Parses a raw string delimited by @c@ using Org's math rules mathStringBetween :: Char -> OrgParser String mathStringBetween c = try $ do mathStart c body <- many1TillNOrLessNewlines mathAllowedNewlines (noneOf (c:"\n\r")) (lookAhead $ mathEnd c) final <- mathEnd c return $ body ++ [final] -- | Parse a single character between @c@ using math rules math1CharBetween :: Char -> OrgParser String math1CharBetween c = try $ do char c res <- noneOf $ c:mathForbiddenBorderChars char c eof <|> () <$ lookAhead (oneOf mathPostChars) return [res] rawMathBetween :: String -> String -> OrgParser String rawMathBetween s e = try $ string s *> manyTill anyChar (try $ string e) -- | Parses the start (opening character) of emphasis emphasisStart :: Char -> OrgParser Char emphasisStart c = try $ do guard =<< afterEmphasisPreChar guard =<< notAfterString char c lookAhead (noneOf emphasisForbiddenBorderChars) pushToInlineCharStack c return c -- | Parses the closing character of emphasis emphasisEnd :: Char -> OrgParser Char emphasisEnd c = try $ do guard =<< notAfterForbiddenBorderChar char c eof <|> () <$ lookAhead acceptablePostChars updateLastStrPos popInlineCharStack return c where acceptablePostChars = surroundingEmphasisChar >>= \x -> oneOf (x ++ emphasisPostChars) mathStart :: Char -> OrgParser Char mathStart c = try $ char c <* notFollowedBy' (oneOf (c:mathForbiddenBorderChars)) mathEnd :: Char -> OrgParser Char mathEnd c = try $ do res <- noneOf (c:mathForbiddenBorderChars) char c eof <|> () <$ lookAhead (oneOf mathPostChars) return res enclosedInlines :: OrgParser a -> OrgParser b -> OrgParser Inlines enclosedInlines start end = try $ trimInlines . mconcat <$> enclosed start end inline enclosedRaw :: OrgParser a -> OrgParser b -> OrgParser String enclosedRaw start end = try $ start *> (onSingleLine <|> spanningTwoLines) where onSingleLine = try $ many1Till (noneOf "\n\r") end spanningTwoLines = try $ anyLine >>= \f -> mappend (f <> " ") <$> onSingleLine -- | Like many1Till, but parses at most @n+1@ lines. @p@ must not consume -- newlines. many1TillNOrLessNewlines :: Int -> OrgParser Char -> OrgParser a -> OrgParser String many1TillNOrLessNewlines n p end = try $ nMoreLines (Just n) mempty >>= oneOrMore where nMoreLines Nothing cs = return cs nMoreLines (Just 0) cs = try $ (cs ++) <$> finalLine nMoreLines k cs = try $ (final k cs <|> rest k cs) >>= uncurry nMoreLines final _ cs = (\x -> (Nothing, cs ++ x)) <$> try finalLine rest m cs = (\x -> (minus1 <$> m, cs ++ x ++ "\n")) <$> try (manyTill p P.newline) finalLine = try $ manyTill p end minus1 k = k - 1 oneOrMore cs = guard (not $ null cs) *> return cs -- Org allows customization of the way it reads emphasis. We use the defaults -- here (see, e.g., the Emacs Lisp variable `org-emphasis-regexp-components` -- for details). -- | Chars allowed to occur before emphasis (spaces and newlines are ok, too) emphasisPreChars :: [Char] emphasisPreChars = "\t \"'({" -- | Chars allowed at after emphasis emphasisPostChars :: [Char] emphasisPostChars = "\t\n !\"'),-.:;?\\}" -- | Chars not allowed at the (inner) border of emphasis emphasisForbiddenBorderChars :: [Char] emphasisForbiddenBorderChars = "\t\n\r \"'," -- | The maximum number of newlines within emphasisAllowedNewlines :: Int emphasisAllowedNewlines = 1 -- LaTeX-style math: see `org-latex-regexps` for details -- | Chars allowed after an inline ($...$) math statement mathPostChars :: [Char] mathPostChars = "\t\n \"'),-.:;?" -- | Chars not allowed at the (inner) border of math mathForbiddenBorderChars :: [Char] mathForbiddenBorderChars = "\t\n\r ,;.$" -- | Maximum number of newlines in an inline math statement mathAllowedNewlines :: Int mathAllowedNewlines = 2 -- | Whether we are right behind a char allowed before emphasis afterEmphasisPreChar :: OrgParser Bool afterEmphasisPreChar = do pos <- getPosition lastPrePos <- orgStateLastPreCharPos <$> getState return . fromMaybe True $ (== pos) <$> lastPrePos -- | Whether the parser is right after a forbidden border char notAfterForbiddenBorderChar :: OrgParser Bool notAfterForbiddenBorderChar = do pos <- getPosition lastFBCPos <- orgStateLastForbiddenCharPos <$> getState return $ lastFBCPos /= Just pos -- | Read a sub- or superscript expression subOrSuperExpr :: OrgParser Inlines subOrSuperExpr = try $ choice [ id <$> charsInBalanced '{' '}' (noneOf "\n\r") , enclosing ('(', ')') <$> charsInBalanced '(' ')' (noneOf "\n\r") , simpleSubOrSuperString ] >>= parseFromString (mconcat <$> many inline) where enclosing (left, right) s = left : s ++ [right] simpleSubOrSuperString :: OrgParser String simpleSubOrSuperString = try $ choice [ string "*" , mappend <$> option [] ((:[]) <$> oneOf "+-") <*> many1 alphaNum ] inlineLaTeX :: OrgParser Inlines inlineLaTeX = try $ do cmd <- inlineLaTeXCommand maybe mzero return $ parseAsMath cmd `mplus` parseAsMathMLSym cmd `mplus` parseAsInlineLaTeX cmd where parseAsMath :: String -> Maybe Inlines parseAsMath cs = B.fromList <$> texMathToPandoc cs parseAsInlineLaTeX :: String -> Maybe Inlines parseAsInlineLaTeX cs = maybeRight $ runParser inlineCommand state "" cs parseAsMathMLSym :: String -> Maybe Inlines parseAsMathMLSym cs = B.str <$> MathMLEntityMap.getUnicode (clean cs) -- dropWhileEnd would be nice here, but it's not available before base 4.5 where clean = reverse . dropWhile (`elem` ("{}" :: String)) . reverse . drop 1 state :: ParserState state = def{ stateOptions = def{ readerParseRaw = True }} texMathToPandoc inp = (maybeRight $ readTeX inp) >>= writePandoc DisplayInline maybeRight :: Either a b -> Maybe b maybeRight = either (const Nothing) Just inlineLaTeXCommand :: OrgParser String inlineLaTeXCommand = try $ do rest <- getInput case runParser rawLaTeXInline def "source" rest of Right (RawInline _ cs) -> do let len = length cs count len anyChar return cs _ -> mzero smart :: OrgParser Inlines smart = do getOption readerSmart >>= guard doubleQuoted <|> singleQuoted <|> choice [orgApostrophe, dash, ellipses] where orgApostrophe = (char '\'' <|> char '\8217') <* updateLastPreCharPos <* updateLastForbiddenCharPos *> return (B.str "\x2019") singleQuoted :: OrgParser Inlines singleQuoted = try $ do singleQuoteStart withQuoteContext InSingleQuote $ B.singleQuoted . trimInlines . mconcat <$> many1Till inline singleQuoteEnd -- doubleQuoted will handle regular double-quoted sections, as well -- as dialogues with an open double-quote without a close double-quote -- in the same paragraph. doubleQuoted :: OrgParser Inlines doubleQuoted = try $ do doubleQuoteStart contents <- mconcat <$> many (try $ notFollowedBy doubleQuoteEnd >> inline) (withQuoteContext InDoubleQuote $ (doubleQuoteEnd <* updateLastForbiddenCharPos) >> return (B.doubleQuoted . trimInlines $ contents)) <|> (return $ (B.str "\8220") <> contents)