summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlbert Krewinkel <albert@zeitkraut.de>2016-05-20 00:15:52 +0200
committerAlbert Krewinkel <albert@zeitkraut.de>2016-05-20 17:01:26 +0200
commit68d388f833c1400e2c6a177c9822cf385aabb5fc (patch)
treed46c35543b9f52df009548a3024cd8cfa2ca1234
parent0160e850173a4ec1c1b46ec1b871c3921041d282 (diff)
Org reader: add :PROPERTIES: drawer support
Headers can have optional `:PROPERTIES:` drawers associated with them. These drawers contain key/value pairs like the header's `id`. The reader adds all listed pairs to the header's attributes; `id` and `class` attributes are handled specially to match the way `Attr` are defined. This also changes behavior of how drawers of unknown type are handled. Instead of including all unknown drawers, those are not read/exported, thereby matching current Emacs behavior. This closes #1877.
-rw-r--r--src/Text/Pandoc/Readers/Org.hs84
-rw-r--r--tests/Tests/Readers/Org.hs19
2 files changed, 70 insertions, 33 deletions
diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs
index a7120389f..d7939c95a 100644
--- a/src/Text/Pandoc/Readers/Org.hs
+++ b/src/Text/Pandoc/Readers/Org.hs
@@ -284,7 +284,7 @@ block = choice [ mempty <$ blanklines
, orgBlock
, figure
, example
- , drawer
+ , genericDrawer
, specialLine
, header
, return <$> hline
@@ -582,26 +582,55 @@ exampleCode = B.codeBlockWith ("", ["example"], [])
exampleLine :: OrgParser String
exampleLine = try $ skipSpaces *> string ": " *> anyLine
--- Drawers for properties or a logbook
-drawer :: OrgParser (F Blocks)
-drawer = try $ do
+
+--
+-- Drawers
+--
+
+-- | A generic drawer which has no special meaning for org-mode.
+genericDrawer :: OrgParser (F Blocks)
+genericDrawer = 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"
+ skipSpaces *> drawerName <* skipSpaces <* newline
+ where drawerName = char ':' *> manyTill nonspaceChar (char ':')
drawerLine :: OrgParser String
-drawerLine = try anyLine
+drawerLine = anyLine
drawerEnd :: OrgParser String
drawerEnd = try $
- skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* P.newline
+ skipSpaces *> stringAnyCase ":END:" <* skipSpaces <* newline
+
+-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
+-- within.
+propertiesDrawer :: OrgParser [(String, String)]
+propertiesDrawer = try $ do
+ drawerType <- drawerStart
+ guard $ map toUpper drawerType == "PROPERTIES"
+ manyTill property (try drawerEnd)
+ where
+ property :: OrgParser (String, String)
+ property = try $ (,) <$> key <*> value
+
+ key :: OrgParser String
+ key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
+
+ value :: OrgParser String
+ value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> P.newline)
+
+keyValuesToAttr :: [(String, String)] -> Attr
+keyValuesToAttr kvs =
+ let
+ id' = fromMaybe mempty . lookup "id" $ kvs
+ cls = fromMaybe mempty . lookup "class" $ kvs
+ kvs' = filter (flip notElem ["id", "class"] . fst) kvs
+ in
+ (id', words cls, kvs')
--
@@ -700,29 +729,28 @@ parseFormat = try $ do
-- | Headers
header :: OrgParser (F Blocks)
header = try $ do
- level <- headerStart
- title <- manyTill inline (lookAhead headerEnd)
- tags <- headerEnd
- let inlns = trimInlinesF . mconcat $ title <> map tagToInlineF tags
- st <- getState
- let inlines = runF inlns st
- attr <- registerHeader nullAttr inlines
+ level <- headerStart
+ title <- manyTill inline (lookAhead $ optional headerTags <* P.newline)
+ tags <- option [] headerTags
+ newline
+ propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)
+ inlines <- runF (tagTitle title tags) <$> getState
+ attr <- registerHeader propAttr inlines
return $ pure (B.headerWith attr level inlines)
where
+ tagTitle :: [F Inlines] -> [String] -> F Inlines
+ tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags
+
tagToInlineF :: String -> F Inlines
tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
-headerEnd :: OrgParser [String]
-headerEnd = option [] headerTags <* newline
-
-headerTags :: OrgParser [String]
-headerTags = try $
- skipSpaces
- *> char ':'
- *> many1 tag
- <* skipSpaces
- where tag = many1 (alphaNum <|> oneOf "@%#_")
- <* char ':'
+ headerTags :: OrgParser [String]
+ headerTags = try $
+ let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
+ in skipSpaces
+ *> char ':'
+ *> many1 tag
+ <* skipSpaces
headerStart :: OrgParser Int
headerStart = try $
diff --git a/tests/Tests/Readers/Org.hs b/tests/Tests/Readers/Org.hs
index 666d93a51..6f5a1bd50 100644
--- a/tests/Tests/Readers/Org.hs
+++ b/tests/Tests/Readers/Org.hs
@@ -412,17 +412,17 @@ tests =
] =?>
para "Before" <> para "After"
- , "Drawer start is the only text in first line of a drawer" =:
+ , "Drawer markers must be the only text in the line" =:
unlines [ " :LOGBOOK: foo"
- , " :END:"
+ , " :END: bar"
] =?>
- para (":LOGBOOK:" <> space <> "foo" <> softbreak <> ":END:")
+ para (":LOGBOOK: foo" <> softbreak <> ":END: bar")
- , "Drawers with unknown names are just text" =:
+ , "Drawers can be arbitrary" =:
unlines [ ":FOO:"
, ":END:"
] =?>
- para (":FOO:" <> softbreak <> ":END:")
+ (mempty::Blocks)
, "Anchor reference" =:
unlines [ "<<link-here>> Target."
@@ -597,6 +597,15 @@ tests =
, headerWith ("but-this-is", [], []) 2 "But this is"
]
+ , "Preferences are treated as header attributes" =:
+ unlines [ "* foo"
+ , " :PROPERTIES:"
+ , " :id: fubar"
+ , " :bar: baz"
+ , " :END:"
+ ] =?>
+ headerWith ("fubar", [], [("bar", "baz")]) 1 "foo"
+
, "Paragraph starting with an asterisk" =:
"*five" =?>
para "*five"