Muse reader: parse anchors immediately after headings as IDs

src/Text/Pandoc/Readers/Muse.hs

@@ -31,7 +31,6 @@ Conversion of Muse text to 'Pandoc' document.
 {-
 TODO:
 - Page breaks (five "*")
-- Headings with anchors (make it round trip with Muse writer)
 - Org tables
 - table.el tables
 - Images with attributes (floating and width)
@@ -241,7 +240,8 @@ header = try $ do
   guard $ level <= 5
   spaceChar
   content <- trimInlinesF . mconcat <$> manyTill inline eol
-  attr <- registerHeader ("", [], []) (runF content defaultParserState)
+  anchorId <- option "" parseAnchor
+  attr <- registerHeader (anchorId, [], []) (runF content defaultParserState)
   return $ B.headerWith attr level <$> content
 
 example :: PandocMonad m => MuseParser m (F Blocks)
@@ -629,14 +629,18 @@ endline = try $ do
   notFollowedBy blankline
   returnF B.softbreak
 
-anchor :: PandocMonad m => MuseParser m (F Inlines)
-anchor = try $ do
+parseAnchor :: PandocMonad m => MuseParser m String
+parseAnchor = try $ do
   getPosition >>= \pos -> guard (sourceColumn pos == 1)
   char '#'
   first <- letter
   rest <- many (letter <|> digit)
   skipMany spaceChar <|> void newline
-  let anchorId = first:rest
+  return $ first:rest
+
+anchor :: PandocMonad m => MuseParser m (F Inlines)
+anchor = try $ do
+  anchorId <- parseAnchor
   return $ return $ B.spanWith (anchorId, [], []) mempty
 
 footnote :: PandocMonad m => MuseParser m (F Inlines)

src/Text/Pandoc/Writers/Muse.hs

@@ -229,7 +229,7 @@ blockToMuse (Header level (ident,_,_) inlines) = do
                  else "#" <> text ident <> cr
   let header' = text $ replicate level '*'
   return $ blankline <> nowrap (header' <> space <> contents)
-                 <> blankline <> attr'
+                 $$ attr' <> blankline
 -- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors
 blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline
 blockToMuse (Table caption _ _ headers rows) =  do

test/Tests/Readers/Muse.hs

@@ -455,6 +455,18 @@ tests =
                     , "</quote>"
                     ] =?>
           blockQuote (para "* Hi")
+        , "Headers consume anchors" =:
+          T.unlines [ "** Foo"
+                    , "#bar"
+                    ] =?>
+          headerWith ("bar",[],[]) 2 "Foo"
+        , "Headers don't consume anchors separated with a blankline" =:
+          T.unlines [ "** Foo"
+                    , ""
+                    , "#bar"
+                    ] =?>
+          header 2 "Foo" <>
+          para (spanWith ("bar", [], []) mempty)
         ]
       , testGroup "Directives"
         [ "Title" =:

test/Tests/Writers/Muse.hs

@@ -234,6 +234,11 @@ tests = [ testGroup "block elements"
                       , ""
                       , "*** Third level"
                       ]
+            , "heading with ID" =:
+               headerWith ("bar", [], []) 2 (text "Foo") =?>
+               unlines [ "** Foo"
+                       , "#bar"
+                      ]
             ]
           , "horizontal rule" =: horizontalRule =?> "----"
           , "escape horizontal rule" =: para (text "----") =?> "<verbatim>----</verbatim>"