Lazy error messages

CHANGELOG.md

@@ -4,6 +4,12 @@ Notable changes to this project are documented in this file. The format is based
 
 ## [Unreleased]
 
+New features:
+
+- Added a new operator `<~?>` (alias of `withLazyErrorMessage`), an analog of
+  `<?>`, but allows the error message to be deferred until there is actually an
+  error. Handy when the error message is expensive to construct. (#129 by @fsoikin)
+
 ## [v7.1.0](https://github.com/purescript-contrib/purescript-parsing/releases/tag/v7.1.0) - 2022-01-06
 
 Breaking changes:

src/Text/Parsing/Parser/Combinators.purs

@@ -24,6 +24,7 @@ module Text.Parsing.Parser.Combinators where
 
 import Prelude
 
+import Control.Lazy (defer)
 import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Monad.State (StateT(..), runStateT)
 import Control.Plus (empty, (<|>))
@@ -43,6 +44,19 @@ withErrorMessage p msg = p <|> fail ("Expected " <> msg)
 
 infixl 3 withErrorMessage as <?>
 
+-- | Provide an error message in the case of failure, but lazily. This is handy
+-- | in cases where constructing the error message is expensive, so it's
+-- | preferable to defer it until an error actually happens.
+-- |
+-- |```purs
+-- |parseBang :: Parser Char
+-- |parseBang = char '!' <~?> \_ -> "Expected a bang"
+-- |```
+withLazyErrorMessage :: forall m s a. Monad m => ParserT s m a -> (Unit -> String) -> ParserT s m a
+withLazyErrorMessage p msg = p <|> defer \_ -> fail ("Expected " <> msg unit)
+
+infixl 3 withLazyErrorMessage as <~?>
+
 -- | Flipped `(<?>)`.
 asErrorMessage :: forall m s a. Monad m => String -> ParserT s m a -> ParserT s m a
 asErrorMessage = flip (<?>)

src/Text/Parsing/Parser/String.purs

@@ -33,8 +33,6 @@ module Text.Parsing.Parser.String
 
 import Prelude hiding (between)
 
-import Control.Alt ((<|>))
-import Control.Lazy (defer)
 import Control.Monad.State (get, put)
 import Data.Array (notElem)
 import Data.Char (fromCharCode)
@@ -45,7 +43,7 @@ import Data.String (CodePoint, Pattern(..), null, singleton, stripPrefix, uncons
 import Data.String.CodeUnits as SCU
 import Data.Tuple (Tuple(..), fst)
 import Text.Parsing.Parser (ParseState(..), ParserT, fail)
-import Text.Parsing.Parser.Combinators (skipMany, tryRethrow, (<?>))
+import Text.Parsing.Parser.Combinators (skipMany, tryRethrow, (<?>), (<~?>))
 import Text.Parsing.Parser.Pos (Position(..))
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -119,19 +117,19 @@ skipSpaces = skipMany (satisfyCodePoint isSpace)
 
 -- | Match one of the BMP `Char`s in the array.
 oneOf :: forall m. Monad m => Array Char -> ParserT String m Char
-oneOf ss = satisfy (flip elem ss) <?> ("one of " <> show ss)
+oneOf ss = satisfy (flip elem ss) <~?> \_ -> "one of " <> show ss
 
 -- | Match any BMP `Char` not in the array.
 noneOf :: forall m. Monad m => Array Char -> ParserT String m Char
-noneOf ss = satisfy (flip notElem ss) <?> ("none of " <> show ss)
+noneOf ss = satisfy (flip notElem ss) <~?> \_ -> "none of " <> show ss
 
 -- | Match one of the Unicode characters in the array.
 oneOfCodePoints :: forall m. Monad m => Array CodePoint -> ParserT String m CodePoint
-oneOfCodePoints ss = satisfyCodePoint (flip elem ss) <|> defer \_ -> fail $ "Expected one of " <> show (singleton <$> ss)
+oneOfCodePoints ss = satisfyCodePoint (flip elem ss) <~?> \_ -> "one of " <> show (singleton <$> ss)
 
 -- | Match any Unicode character not in the array.
 noneOfCodePoints :: forall m. Monad m => Array CodePoint -> ParserT String m CodePoint
-noneOfCodePoints ss = satisfyCodePoint (flip notElem ss) <|> defer \_ -> fail $ "Expected none of " <> show (singleton <$> ss)
+noneOfCodePoints ss = satisfyCodePoint (flip notElem ss) <~?> \_ -> "none of " <> show (singleton <$> ss)
 
 -- | Updates a `Position` by adding the columns and lines in `String`.
 updatePosString :: Position -> String -> Position