New combinator: withRecovery

CHANGELOG.md

@@ -10,6 +10,8 @@ Breaking changes:
 
 New features:
 
+- New combinator `withRecovery` (#224 by @jamesdbrock)
+
 Other improvements:
 
 ## [v10.2.0](https://github.com/purescript-contrib/purescript-parsing/releases/tag/v10.2.0) - 2022-11-30

src/Parsing/Combinators.purs

@@ -43,6 +43,7 @@ module Parsing.Combinators
   ( try
   , tryRethrow
   , lookAhead
+  , withRecovery
   , choice
   , between
   , notFollowedBy
@@ -205,6 +206,29 @@ lookAhead (ParserT k1) = ParserT
         (mkFn2 \_ res -> runFn2 done state1 res)
   )
 
+-- | If the main parser fails, the recovery function will be called to get
+-- | a recovery parser. Then the input stream will be backtracked to where the
+-- | main parser began, and the recovery parser will run.
+-- |
+-- | To save the error for later examination, use a parser return type that
+-- | includes a possible `ParseError`. There is an example of this in the
+-- | test suite.
+withRecovery
+  :: forall s m a. (ParseError -> ParserT s m a)
+  -> ParserT s m a
+  -> ParserT s m a
+withRecovery recover (ParserT k1) = ParserT
+  ( mkFn5 \state1 more lift throw done ->
+    runFn5 k1 state1 more lift
+      (mkFn2 \_ err ->
+        let
+          (ParserT k2) = recover err
+        in
+          runFn5 k2 state1 more lift throw done
+      )
+      done
+  )
+
 -- | Match the phrase `p` as many times as possible.
 -- |
 -- | If `p` never consumes input when it

test/Main.purs

@@ -13,6 +13,7 @@ import Control.Monad.State (State, lift, modify, runState)
 import Data.Array (some, toUnfoldable)
 import Data.Array as Array
 import Data.Bifunctor (lmap, rmap)
+import Data.CodePoint.Unicode (isSpace)
 import Data.CodePoint.Unicode as CodePoint.Unicode
 import Data.Either (Either(..), either, fromLeft, hush)
 import Data.Foldable (oneOf)
@@ -36,7 +37,7 @@ import Effect.Console (log, logShow)
 import Effect.Unsafe (unsafePerformEffect)
 import Node.Process (lookupEnv)
 import Parsing (ParseError(..), ParseState(..), Parser, ParserT, Position(..), consume, fail, getParserT, initialPos, parseErrorMessage, parseErrorPosition, position, region, runParser)
-import Parsing.Combinators (advance, between, chainl, chainl1, chainr, chainr1, choice, empty, endBy, endBy1, lookAhead, many, many1, many1Till, many1Till_, manyIndex, manyTill, manyTill_, notFollowedBy, optionMaybe, replicateA, sepBy, sepBy1, sepEndBy, sepEndBy1, skipMany, skipMany1, try, tryRethrow, (<?>), (<??>), (<~?>))
+import Parsing.Combinators (advance, between, chainl, chainl1, chainr, chainr1, choice, empty, endBy, endBy1, lookAhead, many, many1, many1Till, many1Till_, manyIndex, manyTill, manyTill_, notFollowedBy, optionMaybe, replicateA, sepBy, sepBy1, sepEndBy, sepEndBy1, skipMany, skipMany1, try, tryRethrow, withRecovery, (<?>), (<??>), (<~?>))
 import Parsing.Combinators.Array as Combinators.Array
 import Parsing.Expr (Assoc(..), Operator(..), buildExprParser)
 import Parsing.Language (haskellDef, haskellStyle, javaStyle)
@@ -688,6 +689,24 @@ main = do
   parseErrorTestPosition (string "a\nb\nc\n" *> eof) "a\nb\nc\nd\n" (Position { index: 6, column: 1, line: 4 })
   parseErrorTestPosition (string "\ta" *> eof) "\tab" (Position { index: 2, column: 10, line: 1 })
 
+  assertEqual' "withRecovery1"
+    { actual: runParser "  not-an-int here" do
+        _ <- takeWhile isSpace
+        withRecovery
+          (\err -> do
+            nonint <- takeWhile (not <<< isSpace)
+            pure $ Left
+              { error: err
+              , input: nonint
+              }
+          )
+          (Right <$> intDecimal)
+    , expected: Right $ Left
+        { error: ParseError "Expected Int" (Position {index:2,column:3,line:1})
+        , input: "not-an-int"
+        } :: Either ParseError (Either {error::ParseError, input::String} Int)
+    }
+
   assertEqual' "skipSpaces consumes if position advancement issue #200"
     { actual: runParser " " do
         skipSpaces