src/Markdown.hs

@@ -49,7 +49,7 @@ metadata = bound *> fmap T.pack (many $ try (char '-' <* notFollowedBy (chunk "-
     bound = string "---"
 
 document :: (Logger m, Characters s) => Parser s m Document
-document = Doc <$> many ((notFollowedBy eof) *> element)
+document = Doc <$> many element
 
 element :: (Logger m, Characters s) => Parser s m Element
 element =
@@ -73,23 +73,23 @@ blockEnding = lineEnding *> lineEnding
 
 -- TODO: check if inlineHTML needs to be handled in any markdown posts
 inlineText :: forall m s. (Logger m, Characters s) => Parser s m InlineText
-inlineText = inlineText' $ fail "noop on notFollowedBy"
+inlineText = inlineText' (fail "notFollowedBy noop")
   where
     inlineText' disallow = choice [try $ strikethrough disallow, try $ bold disallow, try $ italic disallow, try $ underlined disallow, try code, try $ link disallow, try $ image disallow, try inline_html, plain_text disallow]
     between' start end middle_piece = between start end $ many ((notFollowedBy end) *> middle_piece)
 
-    strikethrough disallow = Crossed <$> (between' (string "~~") (disallow <|> (void $ string "~~")) (inlineText' (disallow <|> (void $ string "~~"))))
+    strikethrough disallow = Crossed <$> (between' (string "~~") (string "~~") (inlineText' (disallow <|> (void $ string "~~"))))
 
-    bold disallow = Bold <$> (between' (string "**") (disallow <|> (void $ string "**")) (inlineText' (disallow <|> (void $ string "**"))))
+    bold disallow = Bold <$> (between' (string "**") (string "**") (inlineText' (disallow <|> (void $ string "**"))))
 
-    italic disallow = Italic <$> (between' (char '*') ((void $ char '*') <|> disallow) (inlineText' (disallow <|> (void $ char '*'))))
+    italic disallow = Italic <$> (between' (char '*') (char '*') (inlineText' (disallow <|> (void $ char '*'))))
 
-    underlined disallow = Underlined <$> (between' (string "__") ((void $ string "__") <|> disallow) (inlineText' (disallow <|> (void $ string "__"))))
+    underlined disallow = Underlined <$> (between' (string "__") (string "__") (inlineText' (disallow <|> (void $ string "__"))))
 
     code = InlineCode . T.pack <$> (between' (char '`') (char '`') (notFollowedBy lineEnding *> anySingle))
 
     link disallow = do
-      linkText <- between' (char '[') ((void $ char ']') <|> disallow) (logDebug "hmm" *> inlineText' (disallow <|> (void $ char ']')))
+      linkText <- between' (char '[') (char ']') (inlineText' (disallow <|> (void $ char ']')))
       (url, title) <- do
         char '('
         -- might fail on newline char situation
@@ -124,7 +124,7 @@ headingBlock :: (Logger m, Characters s) => Parser s m Element
 headingBlock = do
   heading_level <- length <$> (some $ char '#')
   optional $ char ' '
-  text <- many ((notFollowedBy blockEnding) *> inlineText)
+  text <- many $ inlineText
   pure $ Heading $ H {level = heading_level, text}
 
 fencedCodeBlock :: (Logger m, Characters s) => Parser s m Element
@@ -208,4 +208,4 @@ htmlBlock = do
       pure $ mconcat [name, "=\"", value, "\""]
 
 paragraphBlock :: (Logger m, Characters s) => Parser s m Element
-paragraphBlock = Paragraph . P <$> (many ((notFollowedBy blockEnding) *> inlineText))
+paragraphBlock = Paragraph . P <$> (many inlineText)

tests/Markdown/Parse.hs

@@ -53,6 +53,7 @@ generic_parse inp = lift $ timeout 1000000 $ evaluate $ parse (Markdown.document
 all_compiles :: Property
 all_compiles = property $ do
   xs <- forAll $ Gen.text (Range.linear 0 10) Gen.ascii
+  annotate $ T.unpack xs
   parsed <- generic_parse xs
   case parsed of
     Nothing -> fail $ "Hit Timeout"
@@ -114,6 +115,7 @@ code_block = property $ do
   language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
   code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
   let input = "```" <> language <> "\n" <> code <> "\n```"
+  annotate $ "Input: " <> T.unpack input
   parsed <- generic_parse input
 
   case parsed of
@@ -127,6 +129,7 @@ code_block_hanging = property $ do
   language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
   code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
   let input = "```" <> language <> "\n" <> code <> "```"
+  annotate $ "Input: " <> T.unpack input
   parsed <- generic_parse input
 
   case parsed of
@@ -161,7 +164,7 @@ unordered_list = property $ do
 
   case parsed of
     Nothing -> fail $ "Hit Timeout"
-    (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text text_1], child = Nothing}, LI {content = [Text text_2], child = Nothing}]})]))) -> success
+    (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text text_1], children = []}, LI {content = [Text text_2], children = []}]})]))) -> success
     (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -178,7 +181,7 @@ header_after_unordered_list = property $ do
 
   case parsed of
     Nothing -> fail $ "Hit Timeout"
-    (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text bullet_text], child = Nothing}]}), Heading (H {level = header_level, text = [Text header_text]})]))) -> success
+    (Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text bullet_text], children = []}]}), Heading (H {level = header_level, text = [Text header_text]})]))) -> success
     (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -194,7 +197,7 @@ ordered_list = property $ do
 
   case parsed of
     Nothing -> fail $ "Hit Timeout"
-    (Just (Right (Doc [List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}, LI {content = [Text item_2], child = Nothing}, LI {content = [Text item_3], child = Nothing}]})]))) -> success
+    (Just (Right (Doc [List (L {list_type = Ordered, items = [LI {content = [Text item_1], children = []}, LI {content = [Text item_2], children = []}, LI {content = [Text item_3], children = []}]})]))) -> success
     (Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -212,9 +215,9 @@ multiple_ordered_lists = property $ do
     ( Just
         ( Right
             ( Doc
-                [ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}]}),
-                  List (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]}),
-                  List (L {list_type = Ordered, items = [LI {content = [Text item_3], child = Nothing}]})
+                [ List (L {list_type = Ordered, items = [LI {content = [Text item_1], children = []}]}),
+                  List (L {list_type = Ordered, items = [LI {content = [Text item_2], children = []}]}),
+                  List (L {list_type = Ordered, items = [LI {content = [Text item_3], children = []}]})
                   ]
               )
           )
@@ -239,7 +242,7 @@ nested_unordered_list = property $ do
     ( Just
         ( Right
             ( Doc
-                [ List (L {list_type = Unordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Unordered, items = [LI {content = [Text item_2], child = Nothing}]})}, LI {content = [Text item_3], child = Nothing}]})
+                [ List (L {list_type = Unordered, items = [LI {content = [Text item_1], children = [L {list_type = Unordered, items = [LI {content = [Text item_2], children = []}]}]}, LI {content = [Text item_3], children = []}]})
                   ]
               )
           )
@@ -273,9 +276,9 @@ header_then_ordered_list = property $ do
                     ( L
                         { list_type = Ordered,
                           items =
-                            [ LI {content = [Text item_1], child = Nothing},
-                              LI {content = [Text item_2], child = Nothing},
-                              LI {content = [Text item_3], child = Nothing}
+                            [ LI {content = [Text item_1], children = []},
+                              LI {content = [Text item_2], children = []},
+                              LI {content = [Text item_3], children = []}
                               ]
                         }
                       )