diff options
Diffstat (limited to 'src/Text/Pandoc')
| -rw-r--r-- | src/Text/Pandoc/Readers/Org.hs | 134 |
1 files changed, 94 insertions, 40 deletions
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs index 66cfe720e..025158060 100644 --- a/src/Text/Pandoc/Readers/Org.hs +++ b/src/Text/Pandoc/Readers/Org.hs @@ -43,13 +43,13 @@ import Text.Pandoc.Shared (compactify') import Control.Applicative ( Applicative, pure , (<$>), (<$), (<*>), (<*), (*>), (<**>) ) -import Control.Arrow ((***)) import Control.Monad (foldM, guard, liftM, liftM2, when) import Control.Monad.Reader (Reader, runReader, ask, asks) import Data.Char (toLower) import Data.Default import Data.List (intersperse, isPrefixOf, isSuffixOf) -import Data.Maybe (listToMaybe, fromMaybe) +import qualified Data.Map as M +import Data.Maybe (listToMaybe, fromMaybe, isJust) import Data.Monoid (Monoid, mconcat, mempty, mappend) -- | Parse org-mode string and return a Pandoc document. @@ -74,9 +74,12 @@ parseOrg = do type OrgNoteRecord = (String, F Blocks) type OrgNoteTable = [OrgNoteRecord] +type OrgBlockAttributes = M.Map String String + -- | Org-mode parser state data OrgParserState = OrgParserState { orgStateOptions :: ReaderOptions + , orgStateBlockAttributes :: OrgBlockAttributes , orgStateEmphasisCharStack :: [Char] , orgStateEmphasisNewlines :: Maybe Int , orgStateLastForbiddenCharPos :: Maybe SourcePos @@ -102,6 +105,7 @@ instance Default OrgParserState where defaultOrgParserState :: OrgParserState defaultOrgParserState = OrgParserState { orgStateOptions = def + , orgStateBlockAttributes = M.empty , orgStateEmphasisCharStack = [] , orgStateEmphasisNewlines = Nothing , orgStateLastForbiddenCharPos = Nothing @@ -112,6 +116,19 @@ defaultOrgParserState = OrgParserState , orgStateNotes' = [] } +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 } + updateLastStrPos :: OrgParser () updateLastStrPos = getPosition >>= \p -> updateState $ \s -> s{ orgStateLastStrPos = Just p } @@ -125,19 +142,19 @@ updateLastPreCharPos = getPosition >>= \p -> updateState $ \s -> s{ orgStateLastPreCharPos = Just p} pushToInlineCharStack :: Char -> OrgParser () -pushToInlineCharStack c = updateState $ \st -> - st { orgStateEmphasisCharStack = c:orgStateEmphasisCharStack st } +pushToInlineCharStack c = updateState $ \s -> + s{ orgStateEmphasisCharStack = c:orgStateEmphasisCharStack s } popInlineCharStack :: OrgParser () -popInlineCharStack = updateState $ \st -> - st { orgStateEmphasisCharStack = drop 1 . orgStateEmphasisCharStack $ st } +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 } + s{ orgStateEmphasisNewlines = Just maxNewlines } decEmphasisNewlinesCount :: OrgParser () decEmphasisNewlinesCount = updateState $ \s -> @@ -209,20 +226,50 @@ parseBlocks = mconcat <$> manyTill block eof block :: OrgParser (F Blocks) block = choice [ mempty <$ blanklines - , orgBlock + , optionalAttributes $ choice + [ orgBlock + , figure + , table + ] , example , drawer - , figure , specialLine , header , return <$> hline , list - , table , latexFragment , noteBlock , paraOrPlain ] <?> "block" +optionalAttributes :: OrgParser (F Blocks) -> OrgParser (F 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 (noneOf "\n\r") (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 (F Inlines)) +lookupInlinesAttr attr = try $ do + val <- lookupBlockAttribute attr + maybe (return Nothing) + (fmap Just . parseFromString parseInlines) + val + + -- -- Org Blocks (#+BEGIN_... / #+END_...) -- @@ -235,13 +282,13 @@ orgBlock = try $ do let classArgs = [ translateLang . fromMaybe [] $ listToMaybe args ] case blockType of "comment" -> return mempty - "src" -> returnF $ B.codeBlockWith ("", classArgs, []) content "html" -> returnF $ B.rawBlock "html" content "latex" -> returnF $ B.rawBlock "latex" content "ascii" -> returnF $ B.rawBlock "ascii" content "example" -> returnF $ exampleCode content "quote" -> return $ B.blockQuote <$> contentBlocks "verse" -> parseVerse content + "src" -> codeBlockWithAttr classArgs content _ -> return $ B.divWith ("", [blockType], []) <$> contentBlocks where returnF :: a -> OrgParser (F a) @@ -260,6 +307,18 @@ blockHeader = (,,) <$> blockIndent blockType = map toLower <$> (stringAnyCase "#+begin_" *> many letter) blockArgs = manyTill (many nonspaceChar <* skipSpaces) newline +codeBlockWithAttr :: [String] -> String -> OrgParser (F Blocks) +codeBlockWithAttr classArgs content = do + identifier <- fromMaybe "" <$> lookupBlockAttribute "name" + caption <- lookupInlinesAttr "caption" + let codeBlck = B.codeBlockWith (identifier, classArgs, []) content + return $ maybe (pure codeBlck) (labelDiv codeBlck) caption + where + labelDiv blk value = + B.divWith nullAttr <$> (mappend <$> labelledBlock value + <*> pure blk) + labelledBlock = fmap (B.plain . B.spanWith ("", ["label"], [])) + rawBlockContent :: Int -> String -> OrgParser String rawBlockContent indent blockType = unlines . map commaEscaped <$> manyTill indentedLine blockEnder @@ -333,38 +392,26 @@ drawerEnd = try $ -- Figures (Image on a line by itself, preceded by name and/or caption) figure :: OrgParser (F Blocks) figure = try $ do - (tit, cap) <- (maybe mempty withFigPrefix *** fromMaybe mempty) - <$> nameAndOrCaption + (cap, nam) <- nameAndCaption src <- skipSpaces *> selfTarget <* skipSpaces <* newline guard (isImageFilename src) return $ do cap' <- cap - return $ B.para $ B.image src tit cap' - where withFigPrefix cs = if "fig:" `isPrefixOf` cs - then cs - else "fig:" ++ cs - -nameAndOrCaption :: OrgParser (Maybe String, Maybe (F Inlines)) -nameAndOrCaption = try $ nameFirst <|> captionFirst + return $ B.para $ B.image src nam cap' where - nameFirst = try $ do - n <- name - c <- optionMaybe caption - return (Just n, c) - captionFirst = try $ do - c <- caption - n <- optionMaybe name - return (n, Just c) - -caption :: OrgParser (F Inlines) -caption = try $ annotation "CAPTION" *> inlinesTillNewline - -name :: OrgParser String -name = try $ annotation "NAME" *> skipSpaces *> manyTill anyChar newline - -annotation :: String -> OrgParser String -annotation ann = try $ metaLineStart *> stringAnyCase ann <* char ':' + 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 (F Blocks) specialLine = fmap return . try $ metaLine <|> commentLine @@ -400,6 +447,10 @@ metaKey = map toLower <$> many1 (noneOf ": \n\r") <* char ':' <* skipSpaces +-- +-- Headers +-- + -- | Headers header :: OrgParser (F Blocks) header = try $ do @@ -411,6 +462,7 @@ 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'@. @@ -444,12 +496,14 @@ table = try $ do lookAhead tableStart do rows <- tableRows - return $ return . orgToPandocTable . normalizeTable =<< rowsToTable rows + cptn <- fromMaybe (pure "") <$> lookupInlinesAttr "caption" + return $ (<$> cptn) . orgToPandocTable . normalizeTable =<< rowsToTable rows orgToPandocTable :: OrgTable + -> Inlines -> Blocks -orgToPandocTable (OrgTable _ aligns heads lns) = - B.table "" (zip aligns $ repeat 0) heads lns +orgToPandocTable (OrgTable _ aligns heads lns) caption = + B.table caption (zip aligns $ repeat 0) heads lns tableStart :: OrgParser Char tableStart = try $ skipSpaces *> char '|' |