Muse reader: make code blocks round trip

2 files changed, 41 insertions, 13 deletions

diff --git a/src/Text/Pandoc/Readers/Muse.hs b/src/Text/Pandoc/Readers/Muse.hs
index d24f0ba2b..4f9e9697d 100644
--- a/src/Text/Pandoc/Readers/Muse.hs
+++ b/src/Text/Pandoc/Readers/Muse.hs
@@ -129,6 +129,13 @@ parseHtmlContentWithAttrs tag parser = do
 parseHtmlContent :: PandocMonad m => String -> MuseParser m a -> MuseParser m [a]
 parseHtmlContent tag p = fmap snd (parseHtmlContentWithAttrs tag p)
 
+commonPrefix :: String -> String -> String
+commonPrefix _ [] = []
+commonPrefix [] _ = []
+commonPrefix (x:xs) (y:ys)
+  | x == y    = x : commonPrefix xs ys
+  | otherwise = []
+
 --
 -- directive parsers
 --
@@ -365,7 +372,7 @@ lineBlock = try $ do
 listLine :: PandocMonad m => Int -> MuseParser m String
 listLine markerLength = try $ do
   indentWith markerLength
-  anyLineNewline
+  manyTill anyChar eol
 
 withListContext :: PandocMonad m => MuseParser m a -> MuseParser m a
 withListContext p = do
@@ -379,7 +386,7 @@ withListContext p = do
 listContinuation :: PandocMonad m => Int -> MuseParser m [String]
 listContinuation markerLength = try $ do
   result <- many1 $ listLine markerLength
-  blank <- option id ((++ ["\n"]) <$ blankline)
+  blank <- option id ((++ [""]) <$ blankline)
   return $ blank result
 
 listStart :: PandocMonad m => MuseParser m Int -> MuseParser m Int
@@ -394,17 +401,18 @@ listStart marker = try $ do
 dropSpacePrefix :: [String] -> [String]
 dropSpacePrefix lns =
   map (drop maxIndent) lns
-  where maxIndent = minimum $ map (length . takeWhile (== ' ')) lns
+  where flns = filter (\s -> not $ all (== ' ') s) lns
+        maxIndent = if null flns then 0 else length $ takeWhile (== ' ') $ foldl1 commonPrefix flns
 
 listItemContents :: PandocMonad m => Int -> MuseParser m (F Blocks)
 listItemContents markerLength = do
-  firstLine <- anyLineNewline
+  firstLine <- manyTill anyChar eol
   restLines <- many $ listLine markerLength
-  blank <- option id ((++ ["\n"]) <$ blankline)
+  blank <- option id ((++ [""]) <$ blankline)
   let first = firstLine : blank restLines
   rest <- many $ listContinuation markerLength
   let allLines = concat (first : rest)
-  parseFromString (withListContext parseBlocks) $ concat (dropSpacePrefix allLines) ++ "\n"
+  parseFromString (withListContext parseBlocks) $ unlines (dropSpacePrefix allLines)
 
 listItem :: PandocMonad m => MuseParser m Int -> MuseParser m (F Blocks)
 listItem start = try $ do
@@ -444,8 +452,8 @@ definitionListItem = try $ do
   string "::"
   firstLine <- manyTill anyChar eol
   restLines <- manyTill anyLine endOfListItemElement
-  let lns = (dropWhile (== ' ') firstLine) : dropSpacePrefix restLines
-  lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns ++ "\n"
+  let lns = dropWhile (== ' ') firstLine : dropSpacePrefix restLines
+  lineContent <- parseFromString (withListContext parseBlocks) $ unlines lns
   pure $ do lineContent' <- lineContent
             term' <- term
             pure (term', [lineContent'])
diff --git a/test/Tests/Readers/Muse.hs b/test/Tests/Readers/Muse.hs
index 1f4a9e599..19d5e0fae 100644
--- a/test/Tests/Readers/Muse.hs
+++ b/test/Tests/Readers/Muse.hs
@@ -32,16 +32,12 @@ removeTables :: Block -> Block
 removeTables (Table{}) = Para [Str "table was here"]
 removeTables x = x
 
-removeCodeBlocks :: Block -> Block
-removeCodeBlocks (CodeBlock{}) = Para [Str "table was here"]
-removeCodeBlocks x = x
-
 -- Demand that any AST produced by Muse reader and written by Muse writer can be read back exactly the same way.
 -- Currently we remove code blocks and tables and compare third rewrite to the second.
 -- First and second rewrites are not equal yet.
 roundTrip :: Block -> Bool
 roundTrip b = d'' == d'''
-  where d = walk (removeCodeBlocks . removeTables) $ Pandoc nullMeta [b]
+  where d = walk removeTables $ Pandoc nullMeta [b]
         d' = rewrite d
         d'' = rewrite d'
         d''' = rewrite d''
@@ -348,6 +344,18 @@ tests =
                     , "   </example>"
                     ] =?>
           bulletList [ codeBlock "foo" ]
+        , "Example inside list with empty lines" =:
+          T.unlines [ " - <example>"
+                    , "   foo"
+                    , "   </example>"
+                    , ""
+                    , "   bar"
+                    , ""
+                    , "   <example>"
+                    , "   baz"
+                    , "   </example>"
+                    ] =?>
+          bulletList [ codeBlock "foo" <> para "bar" <> codeBlock "baz" ]
         , "Indented example inside list" =:
           T.unlines [ " -  <example>"
                     , "    foo"
@@ -360,6 +368,18 @@ tests =
                     , "        </example>"
                     ] =?>
           definitionList [ ("foo", [codeBlock "bar"]) ]
+        , "Example inside list definition with empty lines" =:
+          T.unlines [ " term :: <example>"
+                    , "         foo"
+                    , "         </example>"
+                    , ""
+                    , "         bar"
+                    , ""
+                    , "         <example>"
+                    , "         baz"
+                    , "         </example>"
+                    ] =?>
+          definitionList [ ("term", [codeBlock "foo" <> para "bar" <> codeBlock "baz"]) ]
         ]
       , testGroup "Literal blocks"
         [ test emacsMuse "Literal block"