Org reader: include tags in headlines

The Emacs default is to include tags in the headline when exporting.
Instead of just empty spans, which contain the tag name as attribute,
tags are rendered as small caps and wrapped in those spans.
Non-breaking spaces serve as separators for multiple tags.

src/Text/Pandoc/Readers/Org/DocumentTree.hs

@@ -34,6 +34,7 @@ module Text.Pandoc.Readers.Org.DocumentTree
 
 import Control.Monad (guard, void)
 import Data.Char (toLower, toUpper)
+import Data.List ( intersperse )
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Text.Pandoc.Builder (Blocks, Inlines)
@@ -224,7 +225,7 @@ headlineToHeader (Headline {..}) = do
                       Just kw -> todoKeywordToInlines kw <> B.space
                       Nothing -> mempty
                     else mempty
-  let text        = tagTitle (todoText <> headlineText) headlineTags
+  let text        = todoText <> headlineText <> tagsToInlines headlineTags
   let propAttr    = propertiesToAttr headlineProperties
   attr           <- registerHeader propAttr headlineText
   return $ B.headerWith attr headlineLevel text
@@ -259,12 +260,21 @@ propertiesToAttr properties =
   in
     (id', words cls ++ (if isUnnumbered then ["unnumbered"] else []), kvs')
 
-tagTitle :: Inlines -> [Tag] -> Inlines
-tagTitle title tags = title <> (mconcat $ map tagToInline tags)
+tagsToInlines :: [Tag] -> Inlines
+tagsToInlines [] = mempty
+tagsToInlines tags =
+  (B.space <>) . mconcat . intersperse (B.str "\160") . map tagToInline $ tags
+ where
+  tagToInline :: Tag -> Inlines
+  tagToInline t = tagSpan t . B.smallcaps . B.str $ fromTag t
+
+-- | Wrap the given inline in a span, marking it as a tag.
+tagSpan :: Tag -> Inlines -> Inlines
+tagSpan t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)])
+
+
+
 
--- | Convert 
-tagToInline :: Tag -> Inlines
-tagToInline t = B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
 
 -- | Read a :PROPERTIES: drawer and return the key/value pairs contained
 -- within.

test/Tests/Readers/Org.hs

@@ -28,6 +28,10 @@ simpleTable' :: Int
              -> Blocks
 simpleTable' n = table "" (replicate n (AlignDefault, 0.0))
 
+-- | Create a span for the given tag.
+tagSpan :: String -> Inlines
+tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) . smallcaps $ str t
+
 tests :: [TestTree]
 tests =
   [ testGroup "Inlines" $
@@ -729,18 +733,17 @@ tests =
                       , "* old  :ARCHIVE:"
                       , "  boring"
                       ] =?>
-              let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
-              in mconcat [ headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")
-                         , para "boring"
-                         ]
+              mconcat [ headerWith ("old", [], mempty) 1
+                                   ("old" <> space <> tagSpan "ARCHIVE")
+                      , para "boring"
+                      ]
 
           , "include archive tree header only" =:
               unlines [ "#+OPTIONS: arch:headline"
                       , "* old  :ARCHIVE:"
                       , "  boring"
                       ] =?>
-              let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
-              in headerWith ("old", [], mempty) 1 ("old" <> tagSpan "ARCHIVE")
+              headerWith ("old", [], mempty) 1 ("old" <> space <> tagSpan "ARCHIVE")
 
           , "limit headline depth" =:
               unlines [ "#+OPTIONS: H:2"
@@ -898,17 +901,16 @@ tests =
                     , "** Call Mom      :@PHONE:"
                     , "** Call John     :@PHONE:JOHN: "
                     ] =?>
-            let tagSpan t = spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
-            in mconcat [ headerWith ("personal", [], [])
-                                    1
-                                    ("Personal" <> tagSpan "PERSONAL")
-                       , headerWith ("call-mom", [], [])
-                                    2
-                                    ("Call Mom" <> tagSpan "@PHONE")
-                       , headerWith ("call-john", [], [])
-                                    2
-                                    ("Call John" <> tagSpan "@PHONE" <> tagSpan "JOHN")
-                       ]
+            mconcat [ headerWith ("personal", [], [])
+                                 1
+                                 ("Personal " <> tagSpan "PERSONAL")
+                    , headerWith ("call-mom", [], [])
+                                 2
+                                 ("Call Mom " <> tagSpan "@PHONE")
+                    , headerWith ("call-john", [], [])
+                                 2
+                                 ("Call John " <> tagSpan "@PHONE" <> "\160" <> tagSpan "JOHN")
+                    ]
 
         , "Untagged header containing colons" =:
             "* This: is not: tagged" =?>