Merge pull request #2941 from tarleb/org-drawer-improvements

Org drawer improvements

3 files changed, 96 insertions, 17 deletions

diff --git a/src/Text/Pandoc/Readers/Org.hs b/src/Text/Pandoc/Readers/Org.hs
index d7939c95a..621e7107f 100644
--- a/src/Text/Pandoc/Readers/Org.hs
+++ b/src/Text/Pandoc/Readers/Org.hs
@@ -138,7 +138,7 @@ exportSetting = choice
   , ignoredSetting "author"
   , ignoredSetting "c"
   , ignoredSetting "creator"
-  , ignoredSetting "d"
+  , complementableListSetting "d" setExportDrawers
   , ignoredSetting "date"
   , ignoredSetting "e"
   , ignoredSetting "email"
@@ -164,15 +164,53 @@ booleanSetting :: String -> ExportSettingSetter Bool -> OrgParser ()
 booleanSetting settingIdentifier setter = try $ do
   string settingIdentifier
   char ':'
-  value <- many nonspaceChar
-  let boolValue = case value of
-                    "nil" -> False
-                    "{}"  -> False
-                    _     -> True
-  updateState $ modifyExportSettings setter boolValue
+  value <- elispBoolean
+  updateState $ modifyExportSettings setter value
+
+-- | Read an elisp boolean.  Only NIL is treated as false, non-NIL values are
+-- interpreted as true.
+elispBoolean :: OrgParser Bool
+elispBoolean = try $ do
+  value <- many1 nonspaceChar
+  return $ case map toLower value of
+             "nil" -> False
+             "{}"  -> False
+             "()"  -> False
+             _     -> True
+
+-- | A list or a complement list (i.e. a list starting with `not`).
+complementableListSetting :: String
+                          -> ExportSettingSetter (Either [String] [String])
+                          -> OrgParser ()
+complementableListSetting settingIdentifier setter = try $ do
+  _     <- string settingIdentifier <* char ':'
+  value <- choice [ Left <$> complementStringList
+                  , Right <$> stringList
+                  , (\b -> if b then Left [] else Right []) <$> elispBoolean
+                  ]
+  updateState $ modifyExportSettings setter value
+ where
+   -- Read a plain list of strings.
+   stringList :: OrgParser [String]
+   stringList = try $
+     char '('
+       *> sepBy elispString spaces
+       <* char ')'
+
+   -- Read an emacs lisp list specifying a complement set.
+   complementStringList :: OrgParser [String]
+   complementStringList = try $
+     string "(not "
+       *> sepBy elispString spaces
+       <* char ')'
+
+   elispString :: OrgParser String
+   elispString = try $
+     char '"'
+       *> manyTill alphaNum (char '"')
 
 ignoredSetting :: String -> OrgParser ()
-ignoredSetting s = try (() <$ string s <* char ':' <* many nonspaceChar)
+ignoredSetting s = try (() <$ string s <* char ':' <* many1 nonspaceChar)
 
 --
 -- Parser
@@ -588,11 +626,27 @@ exampleLine = try $ skipSpaces *> string ": " *> anyLine
 --
 
 -- | A generic drawer which has no special meaning for org-mode.
+-- Whether or not this drawer is included in the output depends on the drawers
+-- export setting.
 genericDrawer :: OrgParser (F Blocks)
 genericDrawer = try $ do
-  drawerStart
-  manyTill drawerLine (try drawerEnd)
-  return mempty
+  name    <- map toUpper <$> drawerStart
+  content <- manyTill drawerLine (try drawerEnd)
+  state   <- getState
+  -- Include drawer if it is explicitly included in or not explicitly excluded
+  -- from the list of drawers that should be exported.  PROPERTIES drawers are
+  -- never exported.
+  case (exportDrawers . orgStateExportSettings $ state) of
+    _           | name == "PROPERTIES" -> return mempty
+    Left  names | name `elem`    names -> return mempty
+    Right names | name `notElem` names -> return mempty
+    _                                  -> drawerDiv name <$> parseLines content
+ where
+  parseLines :: [String] -> OrgParser (F Blocks)
+  parseLines = parseFromString parseBlocks . (++ "\n") . unlines
+
+  drawerDiv :: String -> F Blocks -> F Blocks
+  drawerDiv drawerName = fmap $ B.divWith (mempty, [drawerName, "drawer"], mempty)
 
 drawerStart :: OrgParser String
 drawerStart = try $
@@ -626,9 +680,10 @@ propertiesDrawer = try $ do
 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
+    lowerKvs = map (\(k, v) -> (map toLower k, v)) kvs
+    id'  = fromMaybe mempty . lookup "custom_id" $ lowerKvs
+    cls  = fromMaybe mempty . lookup "class"     $ lowerKvs
+    kvs' = filter (flip notElem ["custom_id", "class"] . fst) lowerKvs
   in
     (id', words cls, kvs')
 
diff --git a/src/Text/Pandoc/Readers/Org/ParserState.hs b/src/Text/Pandoc/Readers/Org/ParserState.hs
index f84e5e51b..6a902cd46 100644
--- a/src/Text/Pandoc/Readers/Org/ParserState.hs
+++ b/src/Text/Pandoc/Readers/Org/ParserState.hs
@@ -39,8 +39,9 @@ module Text.Pandoc.Readers.Org.ParserState
   , runF
   , returnF
   , ExportSettingSetter
-  , exportSubSuperscripts
+  , ExportSettings (..)
   , setExportSubSuperscripts
+  , setExportDrawers
   , modifyExportSettings
   ) where
 
@@ -76,6 +77,10 @@ type OrgLinkFormatters = M.Map String (String -> String)
 -- These settings can be changed via OPTIONS statements.
 data ExportSettings = ExportSettings
   { exportSubSuperscripts :: Bool -- ^ TeX-like syntax for sub- and superscripts
+  , exportDrawers         :: Either [String] [String]
+  -- ^ Specify drawer names which should be exported.  @Left@ names are
+  -- explicitly excluded from the resulting output while @Right@ means that
+  -- only the listed drawer names should be included.
   }
 
 -- | Org-mode parser state
@@ -155,6 +160,7 @@ defaultOrgParserState = OrgParserState
 defaultExportSettings :: ExportSettings
 defaultExportSettings = ExportSettings
   { exportSubSuperscripts = True
+  , exportDrawers = Left ["LOGBOOK"]
   }
 
 
@@ -163,9 +169,16 @@ defaultExportSettings = ExportSettings
 --
 type ExportSettingSetter a = a -> ExportSettings -> ExportSettings
 
+-- | Set export options for sub/superscript parsing.  The short syntax will
+-- not be parsed if this is set set to @False@.
 setExportSubSuperscripts :: ExportSettingSetter Bool
 setExportSubSuperscripts val es = es { exportSubSuperscripts = val }
 
+-- | Set export options for drawers.  See the @exportDrawers@ in ADT
+-- @ExportSettings@ for details.
+setExportDrawers :: ExportSettingSetter (Either [String] [String])
+setExportDrawers val es = es { exportDrawers = val }
+
 -- | Modify a parser state
 modifyExportSettings :: ExportSettingSetter a -> a -> OrgParserState -> OrgParserState
 modifyExportSettings setter val state =
diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs
index bc400c998..f87aeca81 100644
--- a/src/Text/Pandoc/Writers/Org.hs
+++ b/src/Text/Pandoc/Writers/Org.hs
@@ -110,6 +110,17 @@ isRawFormat f =
 blockToOrg :: Block         -- ^ Block element
            -> State WriterState Doc
 blockToOrg Null = return empty
+blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do
+  contents <- blockListToOrg bs
+  let drawerNameTag = ":" <> text cls <> ":"
+  let keys = vcat $ map (\(k,v) ->
+                       ":" <> text k <> ":"
+                       <> space <> text v) kvs
+  let drawerEndTag = text ":END:"
+  return $ drawerNameTag $$ cr $$ keys $$
+           blankline $$ contents $$
+           blankline $$ drawerEndTag $$
+           blankline
 blockToOrg (Div attrs bs) = do
   contents <- blockListToOrg bs
   let startTag = tagWithAttrs "div" attrs
@@ -239,8 +250,8 @@ 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'
+    kv'  = if (classes == mempty) then kv  else ("CLASS", unwords classes):kv
+    kv'' = if (ident == mempty)   then kv' else ("CUSTOM_ID", ident):kv'
     properties = vcat $ map kvToOrgProperty kv''
   in
     drawerStart <> cr <> properties <> cr <> drawerEnd