Parsing failure context region (#97)

Author: jamesdbrock

src/Text/Parsing/Parser.purs

@@ -13,7 +13,7 @@ module Text.Parsing.Parser
   , position
   , fail
   , failWithPosition
-  , label
+  , region
   ) where
 
 import Prelude
@@ -138,8 +138,9 @@ fail message = failWithPosition message =<< position
 failWithPosition :: forall m s a. Monad m => String -> Position -> ParserT s m a
 failWithPosition message pos = throwError (ParseError message pos)
 
--- | If parsing fails inside this labelled context, then prepend the `String`
--- | to the error `String` in the `ParseError`.
-label :: forall m s a. Monad m => String -> ParserT s m a -> ParserT s m a
-label messagePrefix p = catchError p $ \ (ParseError message pos) ->
-  throwError $ ParseError (messagePrefix <> message) pos
+-- | Contextualize parsing failures inside a region. If a parsing failure
+-- | occurs, then the `ParseError` will be transformed by each containing
+-- | `region` as the parser backs out the call stack.
+region :: forall m s a. Monad m => (ParseError -> ParseError) -> ParserT s m a -> ParserT s m a
+region context p = catchError p $ \err -> throwError $ context err
+

test/Main.purs

@@ -13,7 +13,7 @@ import Data.Tuple (Tuple(..))
 import Effect (Effect)
 import Effect.Console (logShow)
 import Test.Assert (assert')
-import Text.Parsing.Parser (Parser, ParserT, ParseError(..), runParser, parseErrorPosition, label)
+import Text.Parsing.Parser (Parser, ParserT, ParseError(..), runParser, parseErrorPosition, region)
 import Text.Parsing.Parser.Combinators (endBy1, sepBy1, optionMaybe, try, chainl, between)
 import Text.Parsing.Parser.Expr (Assoc(..), Operator(..), buildExprParser)
 import Text.Parsing.Parser.Language (javaStyle, haskellStyle, haskellDef)
@@ -500,11 +500,12 @@ main = do
   case runParser "aa" p of
     Right _ -> assert' "error: ParseError expected!" false
     Left (ParseError message pos) -> do
-      let messageExpected = "context1context2Expected \"b\""
+      let messageExpected = "context1 context2 Expected \"b\""
       assert' ("expected message: " <> messageExpected <> ", message: " <> message) (message == messageExpected)
       logShow messageExpected
    where
-    p = label "context1" $ do
+    prependContext m' (ParseError m pos) = ParseError (m' <> m) pos
+    p = region (prependContext "context1 ") $ do
           _ <- string "a"
-          label "context2" $ do
+          region (prependContext "context2 ") $ do
             string "b"