introduce and use assertConsume

CHANGELOG.md

@@ -13,6 +13,7 @@ New features:
 Bugfixes:
 - Do not export `chainl'` and `chainr'` helper functions (#84 by @chtenb)
 - Issue #69: Fix regex parser to always wrap pattern inside `^(..)` (#80 by @chtenb)
+- Issue #75: Make `many` and cousins terminate when the inner parser does not consume, instead of hang indefinitely (#87 by @chtenb)
 - Issue #73: lookAhead consumes input on failure. Introduce `tryAhead` and correct documentation for `lookAhead` (#86 by @chtenb)
 
 Other improvements:

src/Text/Parsing/StringParser/Combinators.purs

@@ -5,6 +5,9 @@ module Text.Parsing.StringParser.Combinators
   , tryAhead
   , many
   , many1
+  , manyTill
+  , many1Till
+  , assertConsume
   , withError
   , (<?>)
   , between
@@ -22,8 +25,6 @@ module Text.Parsing.StringParser.Combinators
   , chainl1
   , chainr1
   , choice
-  , manyTill
-  , many1Till
   , module Control.Lazy
   ) where
 
@@ -61,14 +62,45 @@ lookAhead (Parser p) = Parser \s ->
 tryAhead :: forall a. Parser a -> Parser a
 tryAhead = try <<< lookAhead
 
--- | Match zero or more times.
+-- | Match a parser zero or more times.
+-- | Stops matching when the parser fails or does not consume anymore.
 many :: forall a. Parser a -> Parser (List a)
-many = manyRec
+many = manyRec <<< assertConsume
 
--- | Match one or more times.
+-- | Match a parser one or more times.
+-- | Stops matching when the parser fails or does not consume anymore.
 many1 :: forall a. Parser a -> Parser (NonEmptyList a)
 many1 p = cons' <$> p <*> many p
 
+-- | Match a parser until a terminator parser matches.
+-- | Fails when the parser does not consume anymore.
+manyTill :: forall a end. Parser a -> Parser end -> Parser (List a)
+manyTill p end = (end *> pure Nil) <|> map NEL.toList (many1Till p end)
+
+-- | Match a parser until a terminator parser matches, requiring at least one match.
+-- | Fails when the parser does not consume anymore.
+many1Till :: forall a end. Parser a -> Parser end -> Parser (NonEmptyList a)
+many1Till p end = do
+  x <- p
+  tailRecM inner (pure x)
+  where
+  ending acc = do
+    _ <- end
+    pure $ Done (NEL.reverse acc)
+  continue acc = do
+    c <- assertConsume p
+    pure $ Loop (NEL.cons c acc)
+  inner acc = ending acc <|> continue acc
+
+-- | Run given parser and fail if the parser did not consume any input.
+assertConsume :: forall a. Parser a -> Parser a
+assertConsume (Parser p) = Parser \s ->
+  case p s of
+    Right result ->
+      if s.position < result.suffix.position then Right result
+      else Left { pos: s.position, error: "Consumed no input." }
+    x -> x
+
 -- | Provide an error message in case of failure.
 withError :: forall a. Parser a -> String -> Parser a
 withError p msg = p <|> fail msg
@@ -164,23 +196,5 @@ chainr1' p f a =
 choice :: forall f a. Foldable f => f (Parser a) -> Parser a
 choice = foldl (<|>) (fail "Nothing to parse")
 
--- | Parse values until a terminator.
-manyTill :: forall a end. Parser a -> Parser end -> Parser (List a)
-manyTill p end = (end *> pure Nil) <|> map NEL.toList (many1Till p end)
-
--- | Parse values until the terminator matches, requiring at least one match.
-many1Till :: forall a end. Parser a -> Parser end -> Parser (NonEmptyList a)
-many1Till p end = do
-  x <- p
-  tailRecM inner (pure x)
-  where
-  ending acc = do
-    _ <- end
-    pure $ Done (NEL.reverse acc)
-  continue acc = do
-    c <- p
-    pure $ Loop (NEL.cons c acc)
-  inner acc = ending acc <|> continue acc
-
 cons' :: forall a. a -> List a -> NonEmptyList a
 cons' h t = NonEmptyList (h :| t)

test/BasicSpecs.purs

@@ -2,7 +2,6 @@ module Test.BasicSpecs where
 
 import Prelude hiding (between)
 
-import Test.Utils (AnyParser(..), mkAnyParser)
 import Control.Alt ((<|>))
 import Control.Monad.Writer (Writer, execWriter, tell)
 import Data.Either (isRight)
@@ -12,9 +11,10 @@ import Data.Traversable (traverse)
 import Effect (Effect)
 import Effect.Class.Console (log)
 import Test.Assert (assert')
+import Test.Utils (AnyParser(..), mkAnyParser)
 import Text.Parsing.StringParser (Parser, runParser)
 import Text.Parsing.StringParser.CodePoints (anyChar, anyDigit, anyLetter, char, eof, skipSpaces, string)
-import Text.Parsing.StringParser.Combinators (try, tryAhead, between, chainl, chainl1, endBy, endBy1, lookAhead, many, many1, manyTill, sepBy, sepBy1, sepEndBy, sepEndBy1)
+import Text.Parsing.StringParser.Combinators (try, tryAhead, between, chainl, chainl1, endBy, endBy1, lookAhead, many, many1, manyTill, many1Till, optionMaybe, sepBy, sepBy1, sepEndBy, sepEndBy1)
 
 type TestInputs = { successes :: Array String, failures :: Array String }
 type TestCase = { name :: String, parser :: AnyParser, inputs :: TestInputs }
@@ -67,10 +67,38 @@ testCases =
     , parser: mkAnyParser $ many (char 'a')
     , inputs: { successes: [ "", "a", "aaaa" ], failures: [ "b" ] }
     }
+  , { name: "many no consumption"
+    , parser: mkAnyParser $ many (eof)
+    , inputs: { successes: [ "" ], failures: [ "b" ] }
+    }
   , { name: "many1"
     , parser: mkAnyParser $ many1 (char 'a')
     , inputs: { successes: [ "a", "aaaa" ], failures: [ "", "b" ] }
     }
+  , { name: "many1 no consumption"
+    , parser: mkAnyParser $ many1 (eof)
+    , inputs: { successes: [ "" ], failures: [ "b" ] }
+    }
+  , { name: "manyTill"
+    , parser: mkAnyParser $ manyTill anyLetter (char ';')
+    , inputs: { successes: [ ";", "a;", "abc;" ], failures: [ "", "a", ";a", "ab", "a;b", "a;b;c" ] }
+    }
+  , { name: "manyTill no consumption"
+    , parser: mkAnyParser $ manyTill (optionMaybe (char 'a')) (char ';')
+    , inputs: { successes: [ ";", "a;", "aaa;" ], failures: [ "", "a", ";a", "ab", "a;b", "a;b;c" ] }
+    }
+  , { name: "manyTill overlapping"
+    , parser: mkAnyParser $ manyTill anyLetter (char 'z')
+    , inputs: { successes: [ "z", "az", "abcz" ], failures: [ "", "a", "za", "ab", "azb", "azbzc" ] }
+    }
+  , { name: "many1Till"
+    , parser: mkAnyParser $ many1Till anyLetter (char ';')
+    , inputs: { successes: [ "a;", "abc;" ], failures: [ "", ";", "a", ";a", "ab", "a;b", "a;b;c" ] }
+    }
+  , { name: "many1Till overlapping"
+    , parser: mkAnyParser $ many1Till anyLetter (char 'z')
+    , inputs: { successes: [ "az", "abcz" ], failures: [ "", "z", "a", "za", "ab", "azb", "azbzc" ] }
+    }
   , { name: "between"
     , parser: mkAnyParser $ between (char 'a') (char 'b') (char 'x')
     , inputs: { successes: [ "axb" ], failures: [ "", "x", "a", "b", "ab" ] }
@@ -99,14 +127,6 @@ testCases =
     , parser: mkAnyParser $ endBy1 anyLetter (char ';')
     , inputs: { successes: [ "a;", "a;b;", "a;b;c;" ], failures: [ "", ";", "a", ";a", "ab", "a;b", "a;b;c" ] }
     }
-  , { name: "manyTill"
-    , parser: mkAnyParser $ manyTill anyLetter (char ';')
-    , inputs: { successes: [ ";", "a;", "abc;" ], failures: [ "", "a", ";a", "ab", "a;b", "a;b;c" ] }
-    }
-  , { name: "manyTill overlapping"
-    , parser: mkAnyParser $ manyTill anyLetter (char 'z')
-    , inputs: { successes: [ "z", "az", "abcz" ], failures: [ "", "a", "za", "ab", "azb", "azbzc" ] }
-    }
   , { name: "chainl"
     , parser: mkAnyParser $ chainl (string "x") (char '+' $> (<>)) ""
     , inputs: { successes: [ "", "x", "x+x+x+x" ], failures: [ "+", "+x", "x+", "x+x+", "xx", "xx+" ] }