From 68d388f833c1400e2c6a177c9822cf385aabb5fc Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Fri, 20 May 2016 00:15:52 +0200
Subject: [PATCH 1/2] 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.
---
src/Text/Pandoc/Readers/Org.hs | 84 ++++++++++++++++++++++------------
tests/Tests/Readers/Org.hs | 19 ++++++--
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"
From cd3282b08dc990f34e64048ed70a07dcbb6b8777 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Fri, 20 May 2016 16:29:15 +0200
Subject: [PATCH 2/2] Org writer: add :PROPERTIES: drawer support
This allows header attributes to be added to org documents in the form
of `:PROPERTIES:` drawers. All available attributes are stored as
key/value pairs. This reflects the way the org reader handles
`:PROPERTIES:` blocks.
This closes #1962.
---
src/Text/Pandoc/Writers/Org.hs | 23 ++++++++-
tests/writer.org | 93 ++++++++++++++++++++++++++++++++++
2 files changed, 114 insertions(+), 2 deletions(-)
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index e57a6fc11..bc400c998 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -137,10 +137,13 @@ blockToOrg (RawBlock f str) | isRawFormat f =
return $ text str
blockToOrg (RawBlock _ _) = return empty
blockToOrg HorizontalRule = return $ blankline $$ "--------------" $$ blankline
-blockToOrg (Header level _ inlines) = do
+blockToOrg (Header level attr inlines) = do
contents <- inlineListToOrg inlines
let headerStr = text $ if level > 999 then " " else replicate level '*'
- return $ headerStr <> " " <> contents <> blankline
+ let drawerStr = if attr == nullAttr
+ then empty
+ else cr <> nest (level + 1) (propertiesDrawer attr)
+ return $ headerStr <> " " <> contents <> drawerStr <> blankline
blockToOrg (CodeBlock (_,classes,_) str) = do
opts <- stOptions <$> get
let tabstop = writerTabStop opts
@@ -230,6 +233,22 @@ definitionListItemToOrg (label, defs) = do
contents <- liftM vcat $ mapM blockListToOrg defs
return $ hang 3 "- " $ label' <> " :: " <> (contents <> cr)
+-- | Convert list of key/value pairs to Org :PROPERTIES: drawer.
+propertiesDrawer :: Attr -> Doc
+propertiesDrawer (ident, classes, kv) =
+ let
+ drawerStart = text ":PROPERTIES:"
+ drawerEnd = text ":END:"
+ kv' = if (classes == mempty) then kv else ("class", unwords classes):kv
+ kv'' = if (ident == mempty) then kv' else ("id", ident):kv'
+ properties = vcat $ map kvToOrgProperty kv''
+ in
+ drawerStart <> cr <> properties <> cr <> drawerEnd
+ where
+ kvToOrgProperty :: (String, String) -> Doc
+ kvToOrgProperty (key, value) =
+ text ":" <> text key <> text ": " <> text value <> cr
+
-- | Convert list of Pandoc block elements to Org.
blockListToOrg :: [Block] -- ^ List of block elements
-> State WriterState Doc
diff --git a/tests/writer.org b/tests/writer.org
index 13bacdfa6..58ea5d033 100644
--- a/tests/writer.org
+++ b/tests/writer.org
@@ -9,30 +9,60 @@ markdown test suite.
--------------
* Headers
+ :PROPERTIES:
+ :id: headers
+ :END:
** Level 2 with an [[/url][embedded link]]
+ :PROPERTIES:
+ :id: level-2-with-an-embedded-link
+ :END:
*** Level 3 with /emphasis/
+ :PROPERTIES:
+ :id: level-3-with-emphasis
+ :END:
**** Level 4
+ :PROPERTIES:
+ :id: level-4
+ :END:
***** Level 5
+ :PROPERTIES:
+ :id: level-5
+ :END:
* Level 1
+ :PROPERTIES:
+ :id: level-1
+ :END:
** Level 2 with /emphasis/
+ :PROPERTIES:
+ :id: level-2-with-emphasis
+ :END:
*** Level 3
+ :PROPERTIES:
+ :id: level-3
+ :END:
with no blank line
** Level 2
+ :PROPERTIES:
+ :id: level-2
+ :END:
with no blank line
--------------
* Paragraphs
+ :PROPERTIES:
+ :id: paragraphs
+ :END:
Here's a regular paragraph.
@@ -48,6 +78,9 @@ here.
--------------
* Block Quotes
+ :PROPERTIES:
+ :id: block-quotes
+ :END:
E-mail style:
@@ -87,6 +120,9 @@ And a following paragraph.
--------------
* Code Blocks
+ :PROPERTIES:
+ :id: code-blocks
+ :END:
Code:
@@ -111,8 +147,14 @@ And:
--------------
* Lists
+ :PROPERTIES:
+ :id: lists
+ :END:
** Unordered
+ :PROPERTIES:
+ :id: unordered
+ :END:
Asterisks tight:
@@ -157,6 +199,9 @@ Minuses loose:
- Minus 3
** Ordered
+ :PROPERTIES:
+ :id: ordered
+ :END:
Tight:
@@ -197,6 +242,9 @@ Multiple paragraphs:
3. Item 3.
** Nested
+ :PROPERTIES:
+ :id: nested
+ :END:
- Tab
@@ -228,6 +276,9 @@ Same thing but with paragraphs:
3. Third
** Tabs and spaces
+ :PROPERTIES:
+ :id: tabs-and-spaces
+ :END:
- this is a list item indented with tabs
@@ -238,6 +289,9 @@ Same thing but with paragraphs:
- this is an example list item indented with spaces
** Fancy list markers
+ :PROPERTIES:
+ :id: fancy-list-markers
+ :END:
2) begins with 2
3) and now 3
@@ -276,6 +330,9 @@ B. Williams
--------------
* Definition Lists
+ :PROPERTIES:
+ :id: definition-lists
+ :END:
Tight using spaces:
@@ -342,6 +399,9 @@ Blank line after term, indented marker, alternate markers:
2. sublist
* HTML Blocks
+ :PROPERTIES:
+ :id: html-blocks
+ :END:
Simple block on one line:
@@ -569,6 +629,9 @@ Hr's:
--------------
* Inline Markup
+ :PROPERTIES:
+ :id: inline-markup
+ :END:
This is /emphasized/, and so /is this/.
@@ -598,6 +661,9 @@ spaces: a\^b c\^d, a~b c~d.
--------------
* Smart quotes, ellipses, dashes
+ :PROPERTIES:
+ :id: smart-quotes-ellipses-dashes
+ :END:
"Hello," said the spider. "'Shelob' is my name."
@@ -619,6 +685,9 @@ Ellipses...and...and....
--------------
* LaTeX
+ :PROPERTIES:
+ :id: latex
+ :END:
- \cite[22-23]{smith.1899}
- $2+2=4$
@@ -649,6 +718,9 @@ Cat & 1 \\ \hline
--------------
* Special Characters
+ :PROPERTIES:
+ :id: special-characters
+ :END:
Here is some unicode:
@@ -703,8 +775,14 @@ Minus: -
--------------
* Links
+ :PROPERTIES:
+ :id: links
+ :END:
** Explicit
+ :PROPERTIES:
+ :id: explicit
+ :END:
Just a [[/url/][URL]].
@@ -725,6 +803,9 @@ Just a [[/url/][URL]].
[[][Empty]].
** Reference
+ :PROPERTIES:
+ :id: reference
+ :END:
Foo [[/url/][bar]].
@@ -753,6 +834,9 @@ Foo [[/url/][bar]].
Foo [[/url/][biz]].
** With ampersands
+ :PROPERTIES:
+ :id: with-ampersands
+ :END:
Here's a [[http://example.com/?foo=1&bar=2][link with an ampersand in the
URL]].
@@ -764,6 +848,9 @@ Here's an [[/script?foo=1&bar=2][inline link]].
Here's an [[/script?foo=1&bar=2][inline link in pointy braces]].
** Autolinks
+ :PROPERTIES:
+ :id: autolinks
+ :END:
With an ampersand: [[http://example.com/?foo=1&bar=2]]
@@ -786,6 +873,9 @@ Auto-links should not occur here: =<http://example.com/>=
--------------
* Images
+ :PROPERTIES:
+ :id: images
+ :END:
From "Voyage dans la Lune" by Georges Melies (1902):
@@ -797,6 +887,9 @@ Here is a movie [[movie.jpg]] icon.
--------------
* Footnotes
+ :PROPERTIES:
+ :id: footnotes
+ :END:
Here is a footnote reference, [1] and another. [2] This should /not/ be a
footnote reference, because it contains a space.[\^my note] Here is an inline