Merge pull request #66 from natefaubion/fix-try

Add tryRethrow

Author: garyb

src/Text/Parsing/Parser.purs

@@ -1,5 +1,5 @@
 module Text.Parsing.Parser
-  ( ParseError
+  ( ParseError(..)
   , parseErrorMessage
   , parseErrorPosition
   , ParseState(..)
@@ -10,7 +10,9 @@ module Text.Parsing.Parser
   , hoistParserT
   , mapParserT
   , consume
+  , position
   , fail
+  , failWithPosition
   ) where
 
 import Prelude
@@ -123,8 +125,14 @@ consume :: forall s m. Monad m => ParserT s m Unit
 consume = modify \(ParseState input position _) ->
   ParseState input position true
 
+-- | Returns the current position in the stream.
+position :: forall s m. Monad m => ParserT s m Position
+position = gets \(ParseState _ pos _) -> pos
+
 -- | Fail with a message.
 fail :: forall m s a. Monad m => String -> ParserT s m a
-fail message = do
-  position <- gets \(ParseState _ pos _) -> pos
-  throwError (ParseError message position)
+fail message = failWithPosition message =<< position
+
+-- | Fail with a message and a position.
+failWithPosition :: forall m s a. Monad m => String -> Position -> ParserT s m a
+failWithPosition message position = throwError (ParseError message position)

src/Text/Parsing/Parser/Combinators.purs

@@ -30,7 +30,7 @@ import Data.List (List(..), (:), many, some, singleton)
 import Data.Maybe (Maybe(..))
 import Data.Newtype (unwrap)
 import Data.Tuple (Tuple(..))
-import Text.Parsing.Parser (ParseState(..), ParserT(..), fail)
+import Text.Parsing.Parser (ParseState(..), ParserT(..), ParseError(..), fail)
 
 -- | Provide an error message in the case of failure.
 withErrorMessage :: forall m s a. Monad m => ParserT s m a -> String -> ParserT s m a
@@ -74,6 +74,14 @@ try p = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState _ _ consumed)) -> do
     Left _ -> pure (Tuple e (ParseState input position consumed))
     _ -> pure (Tuple e s')
 
+-- | Like `try`, but will reannotate the error location to the `try` point.
+tryRethrow :: forall m s a. Monad m => ParserT s m a -> ParserT s m a
+tryRethrow p = (ParserT <<< ExceptT <<< StateT) \(s@(ParseState _ position consumed)) -> do
+  Tuple e s'@(ParseState input' position' _) <- runStateT (runExceptT (unwrap p)) s
+  case e of
+    Left (ParseError err _) -> pure (Tuple (Left (ParseError err position)) (ParseState input' position' consumed))
+    _ -> pure (Tuple e s')
+
 -- | Parse a phrase, without modifying the consumed state or stream position.
 lookAhead :: forall s a m. Monad m => ParserT s m a -> ParserT s m a
 lookAhead p = (ParserT <<< ExceptT <<< StateT) \s -> do

src/Text/Parsing/Parser/String.purs

@@ -10,7 +10,7 @@ import Data.Maybe (Maybe(..))
 import Data.Newtype (wrap)
 import Data.String (Pattern, fromCharArray, length, singleton)
 import Text.Parsing.Parser (ParseState(..), ParserT, fail)
-import Text.Parsing.Parser.Combinators (try, (<?>))
+import Text.Parsing.Parser.Combinators (tryRethrow, (<?>))
 import Text.Parsing.Parser.Pos (updatePosString)
 import Prelude hiding (between)
 
@@ -62,7 +62,7 @@ anyChar = do
 
 -- | Match a character satisfying the specified predicate.
 satisfy :: forall s m. StringLike s => Monad m => (Char -> Boolean) -> ParserT s m Char
-satisfy f = try do
+satisfy f = tryRethrow do
   c <- anyChar
   if f c then pure c
          else fail $ "Character '" <> singleton c <> "' did not satisfy predicate"

src/Text/Parsing/Parser/Token.purs

@@ -39,7 +39,7 @@ import Data.String (toCharArray, null, toLower, fromCharArray, singleton, uncons
 import Data.Tuple (Tuple(..))
 import Math (pow)
 import Text.Parsing.Parser (ParseState(..), ParserT, fail)
-import Text.Parsing.Parser.Combinators (skipMany1, try, skipMany, notFollowedBy, option, choice, between, sepBy1, sepBy, (<?>), (<??>))
+import Text.Parsing.Parser.Combinators (skipMany1, try, tryRethrow, skipMany, notFollowedBy, option, choice, between, sepBy1, sepBy, (<?>), (<??>))
 import Text.Parsing.Parser.Pos (Position)
 import Text.Parsing.Parser.String (satisfy, oneOf, noneOf, string, char)
 import Prelude hiding (when,between)
@@ -57,7 +57,7 @@ token tokpos = do
 
 -- | Create a parser which matches any token satisfying the predicate.
 when :: forall m a. Monad m => (a -> Position) -> (a -> Boolean) -> ParserT (List a) m a
-when tokpos f = try $ do
+when tokpos f = tryRethrow do
   a <- token tokpos
   guard $ f a
   pure a

test/Main.purs

@@ -419,6 +419,11 @@ main = do
     "foo"
     (Position { column: 2, line: 1 })
 
+  parseErrorTestPosition
+    (satisfy (_ == '?'))
+    "foo"
+    (Position { column: 1, line: 1 })
+
   parseTest
     "foo"
     Nil