Merge pull request #193 from purescript-contrib/takemany

advance, manyIndex combinators

Author: jamesdbrock

CHANGELOG.md

@@ -48,6 +48,7 @@ New features:
 - Add the `anyTill` primitive `String` combinator. (#186 by @jamesdbrock)
 - Add the `Parsing.String.Replace` module, copied from
   https://github.com/jamesdbrock/purescript-parsing-replace (#188 by @jamesdbrock)
+- Add the `advance` and `manyIndex` combinators. (#193 by @jamesdbrock)
 
 Bugfixes:
 

src/Parsing.purs

@@ -404,10 +404,11 @@ region context p = catchError p $ \err -> throwError $ context err
 
 -- | `Position` represents the position of the parser in the input stream.
 -- |
--- | - `index` is the position since the start of the input. Starts at 0.
--- | - `line` is the current line in the input. Starts at 1.
+-- | - `index` is the position offset since the start of the input. Starts
+-- |   at *0*.
+-- | - `line` is the current line in the input. Starts at *1*.
 -- | - `column` is the column of the next character in the current line that
--- |   will be parsed. Starts at 1.
+-- |   will be parsed. Starts at *1*.
 newtype Position = Position
   { index :: Int
   , line :: Int

src/Parsing/Combinators.purs

@@ -55,6 +55,7 @@ module Parsing.Combinators
   , manyTill_
   , many1Till
   , many1Till_
+  , manyIndex
   , skipMany
   , skipMany1
   , sepBy
@@ -67,6 +68,7 @@ module Parsing.Combinators
   , chainl1
   , chainr
   , chainr1
+  , advance
   , withErrorMessage
   , (<?>)
   , withLazyErrorMessage
@@ -96,7 +98,7 @@ import Data.Tuple (Tuple(..))
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.Unfoldable (replicateA)
 import Data.Unfoldable1 (replicate1A)
-import Parsing (ParseError(..), ParseState(..), ParserT(..), fail)
+import Parsing (ParseError(..), ParseState(..), ParserT(..), Position(..), fail, position)
 
 -- | Provide an error message in the case of failure.
 withErrorMessage :: forall m s a. ParserT s m a -> String -> ParserT s m a
@@ -440,3 +442,51 @@ manyTill_ p end = tailRecM go Nil
         do
           x <- p
           pure (Loop (x : xs))
+
+-- | Parse the phrase as many times as possible, at least *N* times, but no
+-- | more than *M* times.
+-- | If the phrase can’t parse as least *N* times then the whole
+-- | parser fails. If the phrase parses successfully *M* times then stop.
+-- | The current phrase index, starting at *0*, is passed to the phrase.
+-- |
+-- | Returns the list of parse results and the number of results.
+-- |
+-- | `manyIndex n n (\_ -> p)` is equivalent to `replicateA n p`.
+manyIndex :: forall s m a. Int -> Int -> (Int -> ParserT s m a) -> ParserT s m (Tuple Int (List a))
+manyIndex from to p =
+  if from > to || from < 0 then
+    pure (Tuple 0 Nil)
+  else
+    tailRecM go (Tuple 0 Nil)
+  where
+  go (Tuple i xs) =
+    if i >= to then
+      pure (Done (Tuple i (reverse xs)))
+    else
+      ( do
+          x <- p i
+          pure (Loop (Tuple (i + 1) (x : xs)))
+      )
+        <|>
+          ( if i >= from then
+              pure (Done (Tuple i (reverse xs)))
+            else
+              fail "Expected more phrases"
+          )
+
+-- | If the parser succeeds without advancing the input stream position,
+-- | then force the parser to fail.
+-- |
+-- | This combinator can be used to prevent infinite parser repetition.
+-- |
+-- | Does not depend on or effect the `consumed` flag which indicates whether
+-- | we are committed to this parsing branch.
+advance :: forall s m a. ParserT s m a -> ParserT s m a
+advance p = do
+  Position { index: index1 } <- position
+  x <- p
+  Position { index: index2 } <- position
+  if index2 > index1 then
+    pure x
+  else
+    fail "Expected progress"

test/Main.purs

@@ -34,7 +34,7 @@ import Effect.Console (log, logShow)
 import Effect.Unsafe (unsafePerformEffect)
 import Node.Process (lookupEnv)
 import Parsing (ParseError(..), Parser, ParserT, Position(..), consume, fail, initialPos, parseErrorMessage, parseErrorPosition, position, region, runParser)
-import Parsing.Combinators (between, chainl, chainl1, chainr, chainr1, choice, endBy, endBy1, lookAhead, many, many1, many1Till, many1Till_, manyTill, manyTill_, notFollowedBy, optionMaybe, sepBy, sepBy1, sepEndBy, sepEndBy1, skipMany, skipMany1, try, (<?>), (<??>), (<~?>))
+import Parsing.Combinators (advance, between, chainl, chainl1, chainr, chainr1, choice, endBy, endBy1, lookAhead, many, many1, many1Till, many1Till_, manyIndex, manyTill, manyTill_, notFollowedBy, optionMaybe, sepBy, sepBy1, sepEndBy, sepEndBy1, skipMany, skipMany1, try, (<?>), (<??>), (<~?>))
 import Parsing.Expr (Assoc(..), Operator(..), buildExprParser)
 import Parsing.Language (haskellDef, haskellStyle, javaStyle)
 import Parsing.String (anyChar, anyCodePoint, anyTill, char, eof, match, regex, rest, satisfy, string, takeN)
@@ -1006,3 +1006,37 @@ main = do
           rmap fst <$> splitCap "((🌼)) (()())" (match balancedParens)
     , expected: NonEmptyList $ Right "((🌼))" :| Left " " : Right "(()())" : Nil
     }
+
+  log "\nTESTS manyIndex\n"
+
+  assertEqual' "manyIndex 1"
+    { actual: runParser "aaab" $ manyIndex 0 3 (\_ -> char 'a')
+    , expected: Right (Tuple 3 ('a' : 'a' : 'a' : Nil))
+    }
+  assertEqual' "manyIndex 2"
+    { actual: runParser "aaaa" $ manyIndex 0 3 (\_ -> char 'a')
+    , expected: Right (Tuple 3 ('a' : 'a' : 'a' : Nil))
+    }
+  assertEqual' "manyIndex 3"
+    { actual: runParser "b" $ manyIndex 0 3 (\_ -> char 'a')
+    , expected: Right (Tuple 0 (Nil))
+    }
+  assertEqual' "manyIndex 4"
+    { actual: lmap parseErrorPosition $ runParser "ab" $ manyIndex 3 3 (\_ -> char 'a')
+    , expected: Left (Position { index: 1, line: 1, column: 2 })
+    }
+  assertEqual' "manyIndex 5"
+    { actual: runParser "aaa" $ manyIndex (-2) (1) (\_ -> char 'a')
+    , expected: Right (Tuple 0 (Nil))
+    }
+
+  log "\nTESTS advance\n"
+
+  assertEqual' "advance 1"
+    { actual: runParser "aa" $ advance $ char 'a'
+    , expected: Right 'a'
+    }
+  assertEqual' "advance 2"
+    { actual: lmap parseErrorPosition $ runParser "aa" $ advance consume
+    , expected: Left (Position { index: 0, line: 1, column: 1 })
+    }