infinite loop whack a mole

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 element
+document = Doc <$> many ((notFollowedBy eof) *> 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 "notFollowedBy noop")
+inlineText = inlineText' $ fail "noop on notFollowedBy"
   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 "~~") (string "~~") (inlineText' (disallow <|> (void $ string "~~"))))
+    strikethrough disallow = Crossed <$> (between' (string "~~") (disallow <|> (void $ string "~~")) (inlineText' (disallow <|> (void $ string "~~"))))
 
-    bold disallow = Bold <$> (between' (string "**") (string "**") (inlineText' (disallow <|> (void $ string "**"))))
+    bold disallow = Bold <$> (between' (string "**") (disallow <|> (void $ string "**")) (inlineText' (disallow <|> (void $ string "**"))))
 
-    italic disallow = Italic <$> (between' (char '*') (char '*') (inlineText' (disallow <|> (void $ char '*'))))
+    italic disallow = Italic <$> (between' (char '*') ((void $ char '*') <|> disallow) (inlineText' (disallow <|> (void $ char '*'))))
 
-    underlined disallow = Underlined <$> (between' (string "__") (string "__") (inlineText' (disallow <|> (void $ string "__"))))
+    underlined disallow = Underlined <$> (between' (string "__") ((void $ string "__") <|> disallow) (inlineText' (disallow <|> (void $ string "__"))))
 
     code = InlineCode . T.pack <$> (between' (char '`') (char '`') (notFollowedBy lineEnding *> anySingle))
 
     link disallow = do
-      linkText <- between' (char '[') (char ']') (inlineText' (disallow <|> (void $ char ']')))
+      linkText <- between' (char '[') ((void $ char ']') <|> disallow) (logDebug "hmm" *> 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 $ inlineText
+  text <- many ((notFollowedBy blockEnding) *> 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 inlineText)
+paragraphBlock = Paragraph . P <$> (many ((notFollowedBy blockEnding) *> inlineText))

tests/Markdown/Parse.hs

@@ -53,7 +53,6 @@ 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"
@@ -115,7 +114,6 @@ 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
@@ -129,7 +127,6 @@ 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
@@ -164,7 +161,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], children = []}, LI {content = [Text text_2], children = []}]})]))) -> success
+    (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 tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -181,7 +178,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], children = []}]}), Heading (H {level = header_level, text = [Text header_text]})]))) -> success
+    (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 tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -197,7 +194,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], children = []}, LI {content = [Text item_2], children = []}, LI {content = [Text item_3], children = []}]})]))) -> success
+    (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 tree)) -> fail $ "Incorrect syntax tree: " <> show tree
     (Just (Left e)) -> fail $ errorBundlePretty e
 
@@ -215,9 +212,9 @@ multiple_ordered_lists = property $ do
     ( Just
         ( Right
             ( Doc
-                [ 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 = []}]})
+                [ 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}]})
                   ]
               )
           )
@@ -242,7 +239,7 @@ nested_unordered_list = property $ do
     ( Just
         ( Right
             ( Doc
-                [ 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 = []}]})
+                [ 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}]})
                   ]
               )
           )
@@ -276,9 +273,9 @@ header_then_ordered_list = property $ do
                     ( L
                         { list_type = Ordered,
                           items =
-                            [ LI {content = [Text item_1], children = []},
-                              LI {content = [Text item_2], children = []},
-                              LI {content = [Text item_3], children = []}
+                            [ LI {content = [Text item_1], child = Nothing},
+                              LI {content = [Text item_2], child = Nothing},
+                              LI {content = [Text item_3], child = Nothing}
                               ]
                         }
                       )