diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -10,3 +10,8 @@ * Implemented basic error tracking. * Expanded documentation to fully cover Text parser. * Compatibility with GHC 8.10 and GHC 9.0 on top of GHC 9.2. + +[0.3.0.0] -- April 2022 +[0.3.0.0]: https://github.com/mordae/snack/compare/0.2.0.0...0.3.0.0 + +* Implemented functions to aid with error reporting. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -326,7 +326,7 @@ key <- SC.takeWhile1 isToken _ <- SC.skipSpace _ <- SC.skipSpace - '=' <- SC.char '=' + _ <- SC.char '=' _ <- SC.skipSpace _ <- SC.char '"' val <- SC.scan False scanString @@ -341,7 +341,7 @@ _ <- AC.skipSpace key <- AC.takeWhile1 isToken _ <- AC.skipSpace - '=' <- AC.char '=' + _ <- AC.char '=' _ <- AC.skipSpace _ <- AC.char '"' val <- AC.scan False scanString @@ -357,7 +357,7 @@ key <- ST.takeWhile1 isToken _ <- ST.skipSpace _ <- ST.skipSpace - '=' <- ST.char '=' + _ <- ST.char '=' _ <- ST.skipSpace _ <- ST.char '"' val <- ST.scan False scanString @@ -372,7 +372,7 @@ _ <- AT.skipSpace key <- AT.takeWhile1 isToken _ <- AT.skipSpace - '=' <- AT.char '=' + _ <- AT.char '=' _ <- AT.skipSpace _ <- AT.char '"' val <- AT.scan False scanString diff --git a/lib/Data/ByteString/Parser.hs b/lib/Data/ByteString/Parser.hs --- a/lib/Data/ByteString/Parser.hs +++ b/lib/Data/ByteString/Parser.hs @@ -54,13 +54,19 @@ , wrap , match , label - , extent + , unlabel + , commit + , validate -- * End Of Input , takeByteString + , peekByteString , endOfInput , atEnd + -- * Position + , offset + -- * Miscelaneous -- | -- These are all generic methods, but since I sometimes forget about them, @@ -80,6 +86,7 @@ import Data.Maybe import Data.Word + import Data.List qualified as List import Data.ByteString as BS import Data.ByteString.Unsafe as BS @@ -95,7 +102,7 @@ -- data Result a = Success a {-# UNPACK #-} !ByteString - -- ^ Parser successfully match the input. + -- ^ Parser successfully matched the input. -- Produces the parsing result and the remainder of the input. | Failure [String] {-# UNPACK #-} !ByteString @@ -103,9 +110,7 @@ -- Produces list of expected inputs and the corresponding remainder. | Error String {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int - -- ^ 'fail' was called somewhere during the parsing. - -- Produces the reason and the remainder at the corresponding point - -- with length of the problematic extent. + -- ^ Parser ran into an error. Either syntactic or a validation one. deriving (Eq, Show) @@ -275,7 +280,7 @@ let (pfx, sfx) = splitAt (length str) inp in case pfx == str of True -> Success pfx sfx - False -> Failure [(show pfx)] inp + False -> Failure [show str] inp -- | @@ -398,23 +403,56 @@ -- | - -- Marks an unlabelel extent of the parser. + -- Un-names an extent of the parser. -- - -- When the extent returns an Error, it is adjusted to cover the whole - -- extent, but the reason is left intact. + -- Same as 'label', but removes any expected values upon Failure. + -- Very useful to mark comments and optional whitespace with. -- - {-# INLINE CONLIKE extent #-} - extent :: Parser a -> Parser a - extent par = Parser \inp -> + {-# INLINE CONLIKE unlabel #-} + unlabel :: Parser a -> Parser a + unlabel par = Parser \inp -> case runParser par inp of Success res more -> Success res more - Failure expected more -> Failure expected more + Failure _expected _more -> Failure [] inp Error reason more len -> let len' = len + (length inp - length more) in Error reason inp len' -- | + -- Disable backtracking for the parser. + -- Failure is treated as an Error. + -- + {-# INLINE CONLIKE commit #-} + commit :: Parser a -> Parser a + commit par = Parser \inp -> + case runParser par inp of + Success res more -> Success res more + Error reason more len -> Error reason more len + Failure expected more -> + Error + case expected of + [] -> "Unexpected input." + ex -> "Expected " <> List.intercalate ", " ex <> "." + more 0 + + + -- | + -- Validate parser result and turn it into an Error upon failure. + -- + {-# INLINE CONLIKE validate #-} + validate :: (a -> Either String b) -> Parser a -> Parser b + validate test par = Parser \inp -> + case runParser par inp of + Failure expected more -> Failure expected more + Error reason more len -> Error reason more len + Success res more -> + case test res of + Right res' -> Success res' more + Left reason -> Error reason inp (length inp - length more) + + + -- | -- Accept whatever input remains. -- {-# INLINE takeByteString #-} @@ -423,6 +461,14 @@ -- | + -- Peek at whatever input remains. + -- + {-# INLINE peekByteString #-} + peekByteString :: Parser ByteString + peekByteString = Parser \inp -> Success inp inp + + + -- | -- Accepts end of input and fails if we are not there yet. -- {-# INLINE endOfInput #-} @@ -438,6 +484,13 @@ {-# INLINE atEnd #-} atEnd :: Parser Bool atEnd = Parser \inp -> Success (null inp) inp + + + -- | + -- Calculate offset from the original input and the remainder. + -- + offset :: ByteString -> ByteString -> Int + offset inp more = length inp - length more -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/ByteString/Parser/Char8.hs b/lib/Data/ByteString/Parser/Char8.hs --- a/lib/Data/ByteString/Parser/Char8.hs +++ b/lib/Data/ByteString/Parser/Char8.hs @@ -66,13 +66,22 @@ , wrap , match , label - , extent + , unlabel + , commit + , validate -- * End Of Input , takeByteString + , peekByteString , endOfInput , atEnd + -- * Position + , offset + , position + , explain + , Explanation(..) + -- * Miscelaneous -- | -- These are all generic methods, but since I sometimes forget about them, @@ -92,6 +101,7 @@ import Data.Maybe import Data.Word + import Data.List qualified as List import GHC.Base (unsafeChr) import Data.ByteString as BS @@ -100,8 +110,10 @@ import Snack.Combinators import Data.ByteString.Parser ( Parser(..), Result(..), parseOnly - , string, count, match, label, extent - , takeByteString, endOfInput, atEnd + , string, count, match, label, unlabel, commit + , validate + , takeByteString, peekByteString + , endOfInput, atEnd, offset ) import Data.ByteString.Lex.Fractional qualified as LF @@ -202,7 +214,7 @@ let (pfx, sfx) = splitAt (length str) inp in case toCaseFold pfx == toCaseFold str of True -> Success pfx sfx - False -> Failure [show pfx] inp + False -> Failure [show str] inp -- | @@ -264,7 +276,8 @@ -- | - -- Like 'takeWhile', but requires at least a single character. + -- Like 'Data.ByteString.Parser.Char8.takeWhile', + -- but requires at least a single character. -- {-# INLINE CONLIKE takeWhile1 #-} takeWhile1 :: (Char -> Bool) -> Parser ByteString @@ -350,6 +363,75 @@ {-# INLINE w2c #-} w2c :: Word8 -> Char w2c = unsafeChr . fromIntegral + + + -- | + -- Determine @(line, column)@ from the original input and the remainder. + -- + -- Counts line feed characters leading to the 'offset', so only use it + -- on your slow path. For example when describing parsing errors. + -- + position :: ByteString -> ByteString -> (Int, Int) + position inp more = (succ line, succ column) + where + column = length lastLine + lastLine = takeWhileEnd (10 /=) leader + line = BS.count 10 leader + leader = dropEnd (length more) inp + + + -- | + -- More precise 'Result' description produced by 'explain'. + -- + data Explanation + = Explanation + { exSource :: String + -- ^ Name of the source file. + , exSpanFrom :: (Int, Int) + -- ^ Line and column where the problem starts. + , exSpanTo :: (Int, Int) + -- ^ Line and column where the problem ends. + , exMessage :: String + -- ^ Message associated with the problem. + } + deriving (Eq, Show) + + + -- | + -- Process the result for showing it to the user. + -- + explain :: String -> ByteString -> Result a -> Explanation + explain src inp (Success _ more) = + Explanation { exSource = src + , exSpanFrom = pos + , exSpanTo = pos + , exMessage = "Parsed successfully up to this point." + } + where + pos = position inp more + + + explain src inp (Failure expected more) = + Explanation { exSource = src + , exSpanFrom = pos + , exSpanTo = pos + , exMessage = + case expected of + [] -> "Unexpected input." + ex -> "Expected " <> List.intercalate ", " ex <> "." + } + where + pos = position inp more + + explain src inp (Error reason more len) = + Explanation { exSource = src + , exSpanFrom = from + , exSpanTo = to + , exMessage = reason + } + where + from = position inp more + to = position inp (BS.drop len more) -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Data/Text/Parser.hs b/lib/Data/Text/Parser.hs --- a/lib/Data/Text/Parser.hs +++ b/lib/Data/Text/Parser.hs @@ -63,13 +63,22 @@ , wrap , match , label - , extent + , unlabel + , commit + , validate -- * End Of Input , takeText + , peekText , endOfInput , atEnd + -- * Position + , offset + , position + , explain + , Explanation(..) + -- * Miscelaneous -- | -- These are all generic methods, but since I sometimes forget about them, @@ -89,6 +98,7 @@ import Data.Char import Data.Maybe + import Data.List qualified as List import Data.Text as T import Data.Text.Unsafe as T @@ -109,7 +119,7 @@ -- data Result a = Success a {-# UNPACK #-} !Text - -- ^ Parser successfully match the input. + -- ^ Parser successfully matched the input. -- Produces the parsing result and the remainder of the input. | Failure [String] {-# UNPACK #-} !Text @@ -117,9 +127,7 @@ -- Produces list of expected inputs and the corresponding remainder. | Error String {-# UNPACK #-} !Text {-# UNPACK #-} !Int - -- ^ 'fail' was called somewhere during the parsing. - -- Produces the reason and the remainder at the corresponding point - -- with length of the problematic extent. + -- ^ Parser ran into an error. Either syntactic or a validation one. deriving (Eq, Show) @@ -189,24 +197,7 @@ instance MonadPlus Parser - instance MonadFail Parser where - -- | - -- Fail the whole parser with given reason. - -- - -- If you want the best error report possible, fail at the end of a - -- relevant 'extent'. - -- - -- For example, if you are parsing a mapping that is syntactically valid, - -- but does not contain some mandatory keys, fail after parsing the whole - -- mapping and make sure that the maaping parser and the 'fail' call are - -- enclosed in an 'extent'. - -- - -- That way, the error will indicate the extent remainder and length. - -- - {-# INLINE CONLIKE fail #-} - fail reason = Parser \inp -> Error reason inp 0 - -- | -- Accepts a single, matching character. -- @@ -307,7 +298,7 @@ let (pfx, sfx) = splitAt (length str) inp in case pfx == str of True -> Success pfx sfx - False -> Failure [show pfx] inp + False -> Failure [show str] inp -- | @@ -319,7 +310,7 @@ let (pfx, sfx) = splitAt (length str) inp in case toCaseFold pfx == toCaseFold str of True -> Success pfx sfx - False -> Failure [show pfx] inp + False -> Failure [show str] inp -- | @@ -442,23 +433,56 @@ -- | - -- Marks an unlabelel extent of the parser. + -- Un-names an extent of the parser. -- - -- When the extent returns an Error, it is adjusted to cover the whole - -- extent, but the reason is left intact. + -- Same as 'label', but removes any expected values upon Failure. + -- Very useful to mark comments and optional whitespace with. -- - {-# INLINE CONLIKE extent #-} - extent :: Parser a -> Parser a - extent par = Parser \inp -> + {-# INLINE CONLIKE unlabel #-} + unlabel :: Parser a -> Parser a + unlabel par = Parser \inp -> case runParser par inp of Success res more -> Success res more - Failure expected more -> Failure expected more + Failure _expected _more -> Failure [] inp Error reason more len -> let len' = len + (length inp - length more) in Error reason inp len' -- | + -- Disable backtracking for the parser. + -- Failure is treated as an Error. + -- + {-# INLINE CONLIKE commit #-} + commit :: Parser a -> Parser a + commit par = Parser \inp -> + case runParser par inp of + Success res more -> Success res more + Error reason more len -> Error reason more len + Failure expected more -> + Error + case expected of + [] -> "Unexpected input." + ex -> "Expected " <> List.intercalate ", " ex <> "." + more 0 + + + -- | + -- Validate parser result and turn it into an Error upon failure. + -- + {-# INLINE CONLIKE validate #-} + validate :: (a -> Either String b) -> Parser a -> Parser b + validate test par = Parser \inp -> + case runParser par inp of + Failure expected more -> Failure expected more + Error reason more len -> Error reason more len + Success res more -> + case test res of + Right res' -> Success res' more + Left reason -> Error reason inp (length inp - length more) + + + -- | -- Accept whatever input remains. -- {-# INLINE takeText #-} @@ -467,6 +491,14 @@ -- | + -- Peek at whatever input remains. + -- + {-# INLINE peekText #-} + peekText :: Parser Text + peekText = Parser \inp -> Success inp inp + + + -- | -- Accepts end of input and fails if we are not there yet. -- {-# INLINE endOfInput #-} @@ -554,6 +586,83 @@ case unsafeWithUtf8 LF.readDecimal inp of Just (res, more) -> Success res more Nothing -> Failure ["fractional"] inp + + + + -- | + -- Calculate offset from the original input and the remainder. + -- + offset :: Text -> Text -> Int + offset inp more = length inp - length more + + + -- | + -- Determine @(line, column)@ from the original input and the remainder. + -- + -- Counts line feed characters leading to the 'offset', so only use it + -- on your slow path. For example when describing parsing errors. + -- + position :: Text -> Text -> (Int, Int) + position inp more = (succ line, succ column) + where + column = length lastLine + lastLine = takeWhileEnd ('\n' /=) leader + line = T.count "\n" leader + leader = dropEnd (length more) inp + + + -- | + -- More precise 'Result' description produced by 'explain'. + -- + data Explanation + = Explanation + { exSource :: String + -- ^ Name of the source file. + , exSpanFrom :: (Int, Int) + -- ^ Line and column where the problem starts. + , exSpanTo :: (Int, Int) + -- ^ Line and column where the problem ends. + , exMessage :: String + -- ^ Message associated with the problem. + } + deriving (Eq, Show) + + + -- | + -- Process the result for showing it to the user. + -- + explain :: String -> Text -> Result a -> Explanation + explain src inp (Success _ more) = + Explanation { exSource = src + , exSpanFrom = pos + , exSpanTo = pos + , exMessage = "Parsed successfully up to this point." + } + where + pos = position inp more + + + explain src inp (Failure expected more) = + Explanation { exSource = src + , exSpanFrom = pos + , exSpanTo = pos + , exMessage = + case expected of + [] -> "Unexpected input." + ex -> "Expected " <> List.intercalate ", " ex <> "." + } + where + pos = position inp more + + explain src inp (Error reason more len) = + Explanation { exSource = src + , exSpanFrom = from + , exSpanTo = to + , exMessage = reason + } + where + from = position inp more + to = position inp (T.drop len more) -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/snack.cabal b/snack.cabal --- a/snack.cabal +++ b/snack.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: snack -version: 0.2.0.0 +version: 0.3.0.0 license: CC0-1.0 license-file: LICENSE copyright: Jan Hamal Dvořák @@ -32,7 +32,7 @@ default-language: Haskell2010 default-extensions: BlockArguments LambdaCase ImportQualifiedPost BangPatterns - NamedFieldPuns CPP + NamedFieldPuns CPP OverloadedStrings ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wunused-packages