Muse reader: add support for Text:Amuse multiline headings

2 files changed, 51 insertions, 13 deletions

diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
index 102d8cbb9..9763652bc 100644
--- a/src/Text/Pandoc/Readers/Muse.hs
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -263,8 +263,8 @@ parseBlocks =
        paraStart)
   where
     parseEnd = mempty <$ eof
-    blockStart = (B.<>) <$> (header <|> blockElements <|> emacsNoteBlock)
-                        <*> parseBlocks
+    blockStart = ((B.<>) <$> (emacsHeading <|> blockElements <|> emacsNoteBlock)
+                         <*> parseBlocks) <|> (uncurry (B.<>) <$> amuseHeadingUntil parseBlocks)
     listStart = do
       updateState (\st -> st { museInPara = False })
       uncurry (B.<>) <$> (anyListUntil parseBlocks <|> amuseNoteBlockUntil parseBlocks)
@@ -362,9 +362,10 @@ separator = try $ do
   eol
   return $ return B.horizontalRule
 
--- | Parse a heading.
-header :: PandocMonad m => MuseParser m (F Blocks)
-header = try $ do
+-- | Parse a single-line heading.
+emacsHeading :: PandocMonad m => MuseParser m (F Blocks)
+emacsHeading = try $ do
+  guardDisabled Ext_amuse
   anchorId <- option "" $ try (parseAnchor <* manyTill spaceChar eol)
   getPosition >>= \pos -> guard (sourceColumn pos == 1)
   level <- fmap length $ many1 $ char '*'
@@ -374,6 +375,22 @@ header = try $ do
   attr <- registerHeader (anchorId, [], []) (runF content def)
   return $ B.headerWith attr level <$> content
 
+-- | Parse a multi-line heading.
+-- It is a Text::Amuse extension, Emacs Muse does not allow heading to span multiple lines.
+amuseHeadingUntil :: PandocMonad m
+                  => MuseParser m a -- ^ Terminator parser
+                  -> MuseParser m (F Blocks, a)
+amuseHeadingUntil end = try $ do
+  guardEnabled Ext_amuse
+  anchorId <- option "" $ try (parseAnchor <* manyTill spaceChar eol)
+  getPosition >>= \pos -> guard (sourceColumn pos == 1)
+  level <- fmap length $ many1 $ char '*'
+  guard $ level <= 5
+  spaceChar
+  (content, e) <- paraContentsUntil end
+  attr <- registerHeader (anchorId, [], []) (runF content def)
+  return (B.headerWith attr level <$> content, e)
+
 -- | Parse an example between @{{{@ and @}}}@.
 -- It is an Amusewiki extension influenced by Creole wiki, as described in @Text::Amuse@ documentation.
 example :: PandocMonad m => MuseParser m (F Blocks)
@@ -461,6 +478,16 @@ verseTag = do
 commentTag :: PandocMonad m => MuseParser m (F Blocks)
 commentTag = htmlBlock "comment" >> return mempty
 
+-- | Parse paragraph contents.
+paraContentsUntil :: PandocMonad m
+                  => MuseParser m a -- ^ Terminator parser
+                  -> MuseParser m (F Inlines, a)
+paraContentsUntil end = do
+  updateState (\st -> st { museInPara = True })
+  (l, e) <- someUntil inline $ try (manyTill spaceChar eol >> end)
+  updateState (\st -> st { museInPara = False })
+  return (trimInlinesF $ mconcat l, e)
+
 -- | Parse a paragraph.
 paraUntil :: PandocMonad m
           => MuseParser m a -- ^ Terminator parser
@@ -468,10 +495,7 @@ paraUntil :: PandocMonad m
 paraUntil end = do
   state <- getState
   guard $ not $ museInPara state
-  setState $ state{ museInPara = True }
-  (l, e) <- someUntil inline $ try (manyTill spaceChar eol >> end)
-  updateState (\st -> st { museInPara = False })
-  return (fmap B.para $ trimInlinesF $ mconcat l, e)
+  first (fmap B.para) <$> paraContentsUntil end
 
 noteMarker :: PandocMonad m => MuseParser m String
 noteMarker = try $ do
diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs
index 77b18e066..11eebbdc0 100644
--- a/test/Tests/Readers/Muse.hs
+++ b/test/Tests/Readers/Muse.hs
@@ -558,18 +558,32 @@ tests =
                     ] =?>
           headerWith ("bar",[],[]) 2 "Foo"
         , "Headers don't consume anchors separated with a blankline" =:
-          T.unlines [ "** Foo"
-                    , ""
+          T.unlines [ "; A comment to make sure anchor is not parsed as a directive"
                     , "#bar"
+                    , ""
+                    , "** Foo"
+                    ] =?>
+          para (spanWith ("bar", [], []) mempty) <>
+          header 2 "Foo"
+        , "Headers terminate paragraph" =:
+          T.unlines [ "foo"
+                    , "* bar"
                     ] =?>
-          header 2 "Foo" <>
-          para (spanWith ("bar", [], []) mempty)
+          para "foo" <> header 1 "bar"
         , "Headers terminate lists" =:
           T.unlines [ " - foo"
                     , "* bar"
                     ] =?>
           bulletList [ para "foo" ] <>
           header 1 "bar"
+        , test emacsMuse "Paragraphs terminate Emacs Muse headers"
+          (T.unlines [ "* Foo"
+                    , "bar"
+                    ] =?> header 1 "Foo" <> para "bar")
+        , "Paragraphs don't terminate Text::Amuse headers" =:
+          T.unlines [ "* Foo"
+                    , "bar"
+                    ] =?> header 1 "Foo\nbar"
         ]
       , testGroup "Directives"
         [ "Title" =: