Merge pull request #2934 from tarleb/org-properties-drawer

Org properties drawer

4 files changed, 184 insertions, 35 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/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/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"
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