From 90ac70c79c776a0f41367a6f509d66591aa925ae Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Mon, 29 Jun 2020 20:21:56 +0200
Subject: Org reader: unify keyword handling
Handling of export settings and other keywords (like `#+LINK`) has been
combined and unified.
---
src/Text/Pandoc/Readers/Org/Meta.hs | 142 +++++++++++++++++-------------------
1 file changed, 67 insertions(+), 75 deletions(-)
(limited to 'src')
diff --git a/src/Text/Pandoc/Readers/Org/Meta.hs b/src/Text/Pandoc/Readers/Org/Meta.hs
index ae323f189..7d46841b3 100644
--- a/src/Text/Pandoc/Readers/Org/Meta.hs
+++ b/src/Text/Pandoc/Readers/Org/Meta.hs
@@ -22,7 +22,7 @@ import Text.Pandoc.Readers.Org.Inlines
import Text.Pandoc.Readers.Org.ParserState
import Text.Pandoc.Readers.Org.Parsing
-import Text.Pandoc.Builder (Blocks, Inlines, ToMetaValue)
+import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
@@ -57,13 +57,13 @@ removeMeta key meta' =
-- 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
metaLine :: PandocMonad m => OrgParser m Blocks
-metaLine = mempty <$ metaLineStart <* (optionLine <|> declarationLine)
+metaLine = mempty <$ metaLineStart <* keywordLine
-declarationLine :: PandocMonad m => OrgParser m ()
-declarationLine = try $ do
+keywordLine :: PandocMonad m => OrgParser m ()
+keywordLine = try $ do
key <- T.toLower <$> metaKey
- case Map.lookup key exportSettingHandlers of
- Nothing -> () <$ anyLine
+ case Map.lookup key keywordHandlers of
+ Nothing -> () <$ anyLine -- discard unknown lines
Just hd -> hd
metaKey :: Monad m => OrgParser m Text
@@ -71,33 +71,55 @@ metaKey = T.toLower <$> many1Char (noneOf ": \n\r")
<* char ':'
<* skipSpaces
-exportSettingHandlers :: PandocMonad m => Map Text (OrgParser m ())
-exportSettingHandlers = Map.fromList
- [ ("result" , fmap pure anyLine `parseThen` discard)
- -- Common settings
- , ("author" , lineOfInlines `parseThen` collectLines "author")
- , ("date" , lineOfInlines `parseThen` setField "date")
- , ("description", lineOfInlines `parseThen` collectLines "description")
- , ("keywords" , lineOfInlines `parseThen` collectLines "keywords")
- , ("subtitle" , lineOfInlines `parseThen` collectLines "subtitle")
- , ("title" , lineOfInlines `parseThen` collectLines "title")
- -- LaTeX
- , ("latex_class" , fmap pure anyLine `parseThen` setField "documentclass")
- , ("latex_class_options", (pure . T.filter (`notElem` ("[]" :: String)) <$> anyLine)
- `parseThen` setField "classoption")
- , ("latex_header" , metaExportSnippet "latex" `parseThen`
- collectAsList "header-includes")
- , ("latex_header_extra", metaExportSnippet "latex" `parseThen`
- collectAsList "header-includes")
- -- HTML
- , ("html_head" , metaExportSnippet "html" `parseThen`
- collectAsList "header-includes")
- , ("html_head_extra", metaExportSnippet "html" `parseThen`
- collectAsList "header-includes")
- -- pandoc-specific
- , ("nocite" , lineOfInlines `parseThen` collectLines "nocite")
- , ("header-includes", lineOfInlines `parseThen` collectLines "header-includes")
- , ("institute" , lineOfInlines `parseThen` collectLines "institute")
+infix 0 ~~>
+(~~>) :: a -> b -> (a, b)
+a ~~> b = (a, b)
+
+keywordHandlers :: PandocMonad m => Map Text (OrgParser m ())
+keywordHandlers = Map.fromList
+ [ "author" ~~> lineOfInlines `parseThen` collectLines "author"
+ , "creator" ~~> fmap pure anyLine `parseThen` B.setMeta "creator"
+ , "date" ~~> lineOfInlines `parseThen` B.setMeta "date"
+ , "description" ~~> lineOfInlines `parseThen` collectLines "description"
+ , "email" ~~> fmap pure anyLine `parseThen` B.setMeta "email"
+ , "exclude_tags" ~~> tagList >>= updateState . setExcludedTags
+ , "header-includes" ~~>
+ lineOfInlines `parseThen` collectLines "header-includes"
+ -- HTML-specifix export settings
+ , "html_head" ~~>
+ metaExportSnippet "html" `parseThen` collectAsList "header-includes"
+ , "html_head_extra" ~~>
+ metaExportSnippet "html" `parseThen` collectAsList "header-includes"
+ , "institute" ~~> lineOfInlines `parseThen` collectLines "institute"
+ -- topic keywords
+ , "keywords" ~~> lineOfInlines `parseThen` collectLines "keywords"
+ -- LaTeX-specific export settings
+ , "latex_class" ~~> fmap pure anyLine `parseThen` B.setMeta "documentclass"
+ , "latex_class_options" ~~>
+ (pure . T.filter (`notElem` ("[]" :: String)) <$> anyLine)
+ `parseThen` B.setMeta "classoption"
+ , "latex_header" ~~>
+ metaExportSnippet "latex" `parseThen` collectAsList "header-includes"
+ , "latex_header_extra" ~~>
+ metaExportSnippet "latex" `parseThen` collectAsList "header-includes"
+ -- link and macro
+ , "link" ~~> addLinkFormatter
+ , "macro" ~~> macroDefinition >>= updateState . registerMacro
+ -- pandoc-specific way to include references in the bibliography
+ , "nocite" ~~> lineOfInlines `parseThen` collectLines "nocite"
+ -- compact way to set export settings
+ , "options" ~~> exportSettings
+ -- pandoc-specific way to configure emphasis recognition
+ , "pandoc-emphasis-post" ~~> emphChars >>= updateState . setEmphasisPostChar
+ , "pandoc-emphasis-pre" ~~> emphChars >>= updateState . setEmphasisPreChar
+ -- result markers (ignored)
+ , "result" ~~> void anyLine
+ , "select_tags" ~~> tagList >>= updateState . setSelectedTags
+ , "seq_todo" ~~> todoSequence >>= updateState . registerTodoSequence
+ , "subtitle" ~~> lineOfInlines `parseThen` collectLines "subtitle"
+ , "title" ~~> lineOfInlines `parseThen` collectLines "title"
+ , "todo" ~~> todoSequence >>= updateState . registerTodoSequence
+ , "typ_todo" ~~> todoSequence >>= updateState . registerTodoSequence
]
parseThen :: PandocMonad m
@@ -109,9 +131,6 @@ parseThen p modMeta = do
meta <- orgStateMeta <$> getState
updateState (\st -> st { orgStateMeta = modMeta <$> value <*> meta })
-discard :: a -> Meta -> Meta
-discard = const id
-
collectLines :: Text -> Inlines -> Meta -> Meta
collectLines key value meta =
let value' = appendValue meta (B.toList value)
@@ -146,51 +165,25 @@ collectAsList key value meta =
Just x -> [x]
_ -> []
-setField :: ToMetaValue a => Text -> a -> Meta -> Meta
-setField field value meta = B.setMeta field (B.toMetaValue value) meta
-
-- | Read an format specific meta definition
metaExportSnippet :: Monad m => Text -> OrgParser m (F Inlines)
metaExportSnippet format = pure . B.rawInline format <$> anyLine
---
--- export options
---
-optionLine :: PandocMonad m => OrgParser m ()
-optionLine = try $ do
- key <- metaKey
- case key of
- "link" -> parseLinkFormat >>= uncurry addLinkFormat
- "options" -> exportSettings
- "todo" -> todoSequence >>= updateState . registerTodoSequence
- "seq_todo" -> todoSequence >>= updateState . registerTodoSequence
- "typ_todo" -> todoSequence >>= updateState . registerTodoSequence
- "macro" -> macroDefinition >>= updateState . registerMacro
- "exclude_tags" -> tagList >>= updateState . setExcludedTags
- "select_tags" -> tagList >>= updateState . setSelectedTags
- "pandoc-emphasis-pre" -> emphChars >>= updateState . setEmphasisPreChar
- "pandoc-emphasis-post" -> emphChars >>= updateState . setEmphasisPostChar
- _ -> mzero
-
-addLinkFormat :: Monad m => Text
- -> (Text -> Text)
- -> OrgParser m ()
-addLinkFormat key formatter = updateState $ \s ->
- let fs = orgStateLinkFormatters s
- in s{ orgStateLinkFormatters = Map.insert key formatter fs }
-
-parseLinkFormat :: Monad m => OrgParser m (Text, Text -> Text)
-parseLinkFormat = try $ do
+-- | Parse a link type definition (like @wp https://en.wikipedia.org/wiki/@).
+addLinkFormatter :: Monad m => OrgParser m ()
+addLinkFormatter = try $ do
linkType <- T.cons <$> letter <*> manyChar (alphaNum <|> oneOf "-_") <* skipSpaces
- linkSubst <- parseFormat
- return (linkType, linkSubst)
+ formatter <- parseFormat
+ updateState $ \s ->
+ let fs = orgStateLinkFormatters s
+ in s{ orgStateLinkFormatters = Map.insert linkType formatter fs }
-- | An ad-hoc, single-argument-only implementation of a printf-style format
-- parser.
parseFormat :: Monad m => OrgParser m (Text -> Text)
parseFormat = try $ replacePlain <|> replaceUrl <|> justAppend
where
- -- inefficient, but who cares
+ -- inefficient
replacePlain = try $ (\x -> T.concat . flip intersperse x)
<$> sequence [tillSpecifier 's', rest]
replaceUrl = try $ (\x -> T.concat . flip intersperse x . T.pack . urlEncode . T.unpack)
@@ -229,6 +222,7 @@ setEmphasisPostChar csMb st =
let postChars = fromMaybe (orgStateEmphasisPostChars defaultOrgParserState) csMb
in st { orgStateEmphasisPostChars = postChars }
+-- | Parses emphasis border character like @".,?!"@
emphChars :: Monad m => OrgParser m (Maybe [Char])
emphChars = do
skipSpaces
@@ -239,16 +233,14 @@ lineOfInlines = do
updateLastPreCharPos
trimInlinesF . mconcat <$> manyTill inline newline
---
--- ToDo Sequences and Keywords
---
+-- | Parses ToDo sequences / keywords like @TODO DOING | DONE@.
todoSequence :: Monad m => OrgParser m TodoSequence
todoSequence = try $ do
todoKws <- todoKeywords
doneKws <- optionMaybe $ todoDoneSep *> todoKeywords
newline
- -- There must be at least one DONE keyword. The last TODO keyword is taken if
- -- necessary.
+ -- There must be at least one DONE keyword. The last TODO keyword is
+ -- taken if necessary.
case doneKws of
Just done -> return $ keywordsToSequence todoKws done
Nothing -> case reverse todoKws of
--
cgit v1.2.3