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,41 @@ lookAhead (ParserT k1) = ParserT
         (mkFn2 \_ res -> runFn2 done state1 res)
   )
 
+-- | If the main parser fails, the recovery function will be called
+-- | on the `ParseError` to get
+-- | a recovery parser. Then the input stream will be backtracked to where the
+-- | main parser began, and the recovery parser will run.
+-- |
+-- | The recovery parser should typically consume input until it is safe to
+-- | resume normal parsing and then return some data describing the parse
+-- | failure and recovery.
+-- |
+-- | If the recovery parser fails, the original `ParseError` from the main parser
+-- | will be returned. There is no way to see the error from the recovery parser.
+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 \state2 err ->
+            let
+              (ParserT k2) = recover err
+            in
+              runFn5 k2 state1 more lift
+                --throw
+                -- https://hackage.haskell.org/package/megaparsec-9.3.0/docs/Text-Megaparsec.html#v:withRecovery
+                -- “if recovery fails, the original error message is reported as
+                -- if without withRecovery. In no way can the recovering parser r
+                -- influence error messages.”
+                (mkFn2 \_ _ -> runFn2 throw state2 err)
+                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,25 @@ 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