diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -15,3 +15,8 @@ [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. + +[0.4.0.0] -- July 2022 +[0.4.0.0]: https://github.com/mordae/snack/compare/0.3.0.0...0.4.0.0 + +* Replaced `commit` with `branch` to deal with unwanted backtracking. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -58,10 +58,12 @@ {-# NOINLINE scMedia #-} scMedia :: ByteString -> Maybe [Media ByteString] - scMedia = SC.parseOnly (pMediaList <* SC.endOfInput) + scMedia = SC.parseOnly (SC.skipSpace *> pMediaList <* SC.endOfInput) where - pMedia :: SC.Parser (Media ByteString) + pMediaList :: SC.Parser [Media ByteString] pMediaList = pMedia `SC.sepBy` pSeparator + + pMedia :: SC.Parser (Media ByteString) pMedia = do mainType <- pToken subType <- (SC.char '/' *> pToken) <|> pure "" @@ -74,38 +76,35 @@ pParameter :: SC.Parser (ByteString, ByteString) pParameter = do - _ <- SC.takeWhile SC.isSpace - _ <- SC.char ';' + _ <- SC.char ';' <* SC.skipSpace name <- pToken - _ <- SC.char '=' + _ <- SC.char '=' <* SC.skipSpace value <- pValue return (name, value) pQuality :: SC.Parser Float pQuality = do - _ <- SC.takeWhile SC.isSpace - _ <- SC.char ';' - _ <- pSpaced $ SC.char 'q' - _ <- SC.char '=' + _ <- SC.char ';' <* SC.skipSpace + _ <- SC.char 'q' <* SC.skipSpace + _ <- SC.char '=' <* SC.skipSpace SC.fractional pToken :: SC.Parser ByteString - pToken = pSpaced $ SC.label "token" $ SC.takeTill1 isSpecial + pToken = SC.label "token" $ SC.takeTill1 isSpecial <* SC.skipSpace pSeparator :: SC.Parser Char - pSeparator = pSpaced $ SC.char ',' + pSeparator = SC.char ',' <* SC.skipSpace pValue :: SC.Parser ByteString - pValue = pToken <|> pQuotedStr + pValue = SC.branch [ (SC.char '"', \_ -> pQuotedStr) + , ( pure ' ', \_ -> pToken) + ] pQuotedStr :: SC.Parser ByteString - pQuotedStr = pSpaced $ SC.label "quoted string" $ pQuoted $ SC.takeWhile isStrChar - - pSpaced :: SC.Parser a -> SC.Parser a - pSpaced p = p `SC.wrap` SC.takeWhile SC.isSpace + pQuotedStr = pString <* SC.char '"' <* SC.skipSpace - pQuoted :: SC.Parser a -> SC.Parser a - pQuoted p = SC.char '"' *> p <* SC.char '"' + pString :: SC.Parser ByteString + pString = SC.label "string" $ SC.takeWhile isStrChar isStrChar :: (Char -> Bool) isStrChar c = c /= '\\' && c /= '"' @@ -124,10 +123,12 @@ {-# NOINLINE acMedia #-} acMedia :: ByteString -> Either String [Media ByteString] - acMedia = AC.parseOnly (pMediaList <* AC.endOfInput) + acMedia = AC.parseOnly (AC.skipSpace *> pMediaList <* AC.endOfInput) where - pMedia :: AC.Parser (Media ByteString) + pMediaList :: AC.Parser [Media ByteString] pMediaList = pMedia `AC.sepBy` pSeparator + + pMedia :: AC.Parser (Media ByteString) pMedia = do mainType <- pToken subType <- (AC.char '/' *> pToken) <|> pure "" @@ -140,38 +141,33 @@ pParameter :: AC.Parser (ByteString, ByteString) pParameter = do - _ <- AC.skipSpace - _ <- AC.char ';' + _ <- AC.char ';' <* AC.skipSpace name <- pToken - _ <- AC.char '=' + _ <- AC.char '=' <* AC.skipSpace value <- pValue return (name, value) pQuality :: AC.Parser Float pQuality = do - _ <- AC.skipSpace - _ <- AC.char ';' - _ <- pSpaced $ AC.char 'q' - _ <- AC.char '=' + _ <- AC.char ';' <* AC.skipSpace + _ <- AC.char 'q' <* AC.skipSpace + _ <- AC.char '=' <* AC.skipSpace AC.rational pToken :: AC.Parser ByteString - pToken = pSpaced $ AC.takeTill isSpecial + pToken = AC.takeTill isSpecial <* AC.skipSpace pSeparator :: AC.Parser Char - pSeparator = pSpaced $ AC.char ',' + pSeparator = AC.char ',' <* AC.skipSpace pValue :: AC.Parser ByteString - pValue = pToken <|> pQuotedStr + pValue = pQuotedStr <|> pToken pQuotedStr :: AC.Parser ByteString - pQuotedStr = pSpaced $ pQuoted $ AC.takeWhile isStrChar - - pSpaced :: AC.Parser a -> AC.Parser a - pSpaced p = AC.skipSpace *> p <* AC.skipSpace + pQuotedStr = pQuoted $ AC.takeWhile isStrChar pQuoted :: AC.Parser a -> AC.Parser a - pQuoted p = AC.char '"' *> p <* AC.char '"' + pQuoted p = AC.char '"' *> p <* AC.char '"' <* AC.skipSpace isStrChar :: (Char -> Bool) isStrChar c = c /= '\\' && c /= '"' @@ -189,10 +185,12 @@ {-# NOINLINE stMedia #-} stMedia :: Text -> Maybe [Media Text] - stMedia = ST.parseOnly (pMediaList <* ST.endOfInput) + stMedia = ST.parseOnly (ST.skipSpace *> pMediaList <* ST.endOfInput) where - pMedia :: ST.Parser (Media Text) + pMediaList :: ST.Parser [Media Text] pMediaList = pMedia `ST.sepBy` pSeparator + + pMedia :: ST.Parser (Media Text) pMedia = do mainType <- pToken subType <- (ST.char '/' *> pToken) <|> pure "" @@ -205,38 +203,35 @@ pParameter :: ST.Parser (Text, Text) pParameter = do - _ <- ST.takeWhile ST.isSpace - _ <- ST.char ';' + _ <- ST.char ';' <* ST.skipSpace name <- pToken - _ <- ST.char '=' + _ <- ST.char '=' <* ST.skipSpace value <- pValue return (name, value) pQuality :: ST.Parser Float pQuality = do - _ <- ST.takeWhile ST.isSpace - _ <- ST.char ';' - _ <- pSpaced $ ST.char 'q' - _ <- ST.char '=' + _ <- ST.char ';' <* ST.skipSpace + _ <- ST.char 'q' <* ST.skipSpace + _ <- ST.char '=' <* ST.skipSpace ST.fractional pToken :: ST.Parser Text - pToken = pSpaced $ ST.takeTill1 isSpecial + pToken = ST.takeTill1 isSpecial <* ST.skipSpace pSeparator :: ST.Parser Char - pSeparator = pSpaced $ ST.char ',' + pSeparator = ST.char ',' <* ST.skipSpace pValue :: ST.Parser Text - pValue = pToken <|> pQuotedStr + pValue = ST.branch [ (ST.char '"', \_ -> pQuotedStr) + , ( pure ' ', \_ -> pToken) + ] pQuotedStr :: ST.Parser Text - pQuotedStr = pSpaced $ pQuoted $ ST.takeWhile isStrChar - - pSpaced :: ST.Parser a -> ST.Parser a - pSpaced p = p `ST.wrap` ST.takeWhile ST.isSpace + pQuotedStr = pString <* ST.char '"' <* ST.skipSpace - pQuoted :: ST.Parser a -> ST.Parser a - pQuoted p = ST.char '"' *> p <* ST.char '"' + pString :: ST.Parser Text + pString = ST.label "string" $ ST.takeWhile isStrChar isStrChar :: (Char -> Bool) isStrChar c = c /= '\\' && c /= '"' @@ -255,10 +250,12 @@ {-# NOINLINE atMedia #-} atMedia :: Text -> Either String [Media Text] - atMedia = AT.parseOnly (pMediaList <* AT.endOfInput) + atMedia = AT.parseOnly (AT.skipSpace *> pMediaList <* AT.endOfInput) where - pMedia :: AT.Parser (Media Text) + pMediaList :: AT.Parser [Media Text] pMediaList = pMedia `AT.sepBy` pSeparator + + pMedia :: AT.Parser (Media Text) pMedia = do mainType <- pToken subType <- (AT.char '/' *> pToken) <|> pure "" @@ -271,38 +268,33 @@ pParameter :: AT.Parser (Text, Text) pParameter = do - _ <- AT.skipSpace - _ <- AT.char ';' + _ <- AT.char ';' <* AT.skipSpace name <- pToken - _ <- AT.char '=' + _ <- AT.char '=' <* AT.skipSpace value <- pValue return (name, value) pQuality :: AT.Parser Float pQuality = do - _ <- AT.skipSpace - _ <- AT.char ';' - _ <- pSpaced $ AT.char 'q' - _ <- AT.char '=' + _ <- AT.char ';' <* AT.skipSpace + _ <- AT.char 'q' <* AT.skipSpace + _ <- AT.char '=' <* AT.skipSpace AT.rational pToken :: AT.Parser Text - pToken = pSpaced $ AT.takeTill isSpecial + pToken = AT.takeTill isSpecial <* AT.skipSpace pSeparator :: AT.Parser Char - pSeparator = pSpaced $ AT.char ',' + pSeparator = AT.char ',' <* AT.skipSpace pValue :: AT.Parser Text - pValue = pToken <|> pQuotedStr + pValue = pQuotedStr <|> pToken pQuotedStr :: AT.Parser Text - pQuotedStr = pSpaced $ pQuoted $ AT.takeWhile isStrChar - - pSpaced :: AT.Parser a -> AT.Parser a - pSpaced p = AT.skipSpace *> p <* AT.skipSpace + pQuotedStr = pQuoted $ AT.takeWhile isStrChar pQuoted :: AT.Parser a -> AT.Parser a - pQuoted p = AT.char '"' *> p <* AT.char '"' + pQuoted p = AT.char '"' *> p <* AT.char '"' <* AT.skipSpace isStrChar :: (Char -> Bool) isStrChar c = c /= '\\' && c /= '"' @@ -325,7 +317,6 @@ _ <- SC.skipSpace key <- SC.takeWhile1 isToken _ <- SC.skipSpace - _ <- SC.skipSpace _ <- SC.char '=' _ <- SC.skipSpace _ <- SC.char '"' @@ -355,7 +346,6 @@ pKeyValue = do _ <- ST.skipSpace key <- ST.takeWhile1 isToken - _ <- ST.skipSpace _ <- ST.skipSpace _ <- ST.char '=' _ <- ST.skipSpace 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 @@ -42,6 +42,7 @@ -- * Combinators , provided , choice + , branch , Snack.Combinators.count , optional , eitherP @@ -55,7 +56,6 @@ , match , label , unlabel - , commit , validate -- * End Of Input @@ -84,9 +84,9 @@ import Control.Applicative import Control.Monad + import Data.List qualified as List import Data.Maybe import Data.Word - import Data.List qualified as List import Data.ByteString as BS import Data.ByteString.Unsafe as BS @@ -225,11 +225,15 @@ -- @ -- {-# INLINE CONLIKE parseOnly #-} - parseOnly :: Parser a -> ByteString -> Maybe a + parseOnly :: Parser a -> ByteString -> Either String a parseOnly par = \inp -> case runParser par inp of - Success res _ -> Just res - _otherwise -> Nothing + Success res _ -> Right res + Error reason _ _ -> Left reason + Failure expected _ -> + case expected of + [] -> Left $ "Unexpected input." + ex -> Left $ "Expected " <> List.intercalate ", " ex <> "." -- | @@ -420,24 +424,6 @@ -- | - -- 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 #-} @@ -450,6 +436,34 @@ case test res of Right res' -> Success res' more Left reason -> Error reason inp (length inp - length more) + + + -- | + -- Given list of matchers and parsers, runs the first parser whose matcher + -- succeeds on the input. This pattern makes for a simpler alternative to + -- @try@ used in other parser combinator libraries. + -- + -- Example: + -- + -- @ + -- pProperty = branch [ ( string "public" <* skipSpace + -- , \_ -> Property Public <$> pToken + -- ) + -- , ( string "private" <* skipSpace + -- , \_ -> Property Private <$> pToken + -- ) + -- ] + -- @ + -- + {-# INLINE CONLIKE branch #-} + branch :: [(Parser a, a -> Parser b)] -> Parser b + branch [] = Parser \inp -> Failure [] inp + branch ((Parser test, finish) : alts) = + Parser \inp -> + case test inp of + Success res more -> runParser (finish res) more + Error reason more len -> Error reason more len + Failure _expected _more -> runParser (branch alts) inp -- | diff --git a/lib/Data/ByteString/Parser.hs-boot b/lib/Data/ByteString/Parser.hs-boot --- a/lib/Data/ByteString/Parser.hs-boot +++ b/lib/Data/ByteString/Parser.hs-boot @@ -1,6 +1,7 @@ module Data.ByteString.Parser where import Control.Applicative + import Control.Monad import Data.ByteString (ByteString) data Result a @@ -19,3 +20,4 @@ instance Applicative Parser instance Alternative Parser instance Monad Parser + instance MonadPlus Parser 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 @@ -54,6 +54,7 @@ -- * Combinators , provided , choice + , branch , Data.ByteString.Parser.count , optional , eitherP @@ -67,7 +68,6 @@ , match , label , unlabel - , commit , validate -- * End Of Input @@ -110,8 +110,8 @@ import Snack.Combinators import Data.ByteString.Parser ( Parser(..), Result(..), parseOnly - , string, count, match, label, unlabel, commit - , validate + , string, count, match, label, unlabel + , validate, branch , takeByteString, peekByteString , endOfInput, atEnd, offset ) 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 @@ -51,6 +51,7 @@ -- * Combinators , provided , choice + , branch , Snack.Combinators.count , optional , eitherP @@ -64,7 +65,6 @@ , match , label , unlabel - , commit , validate -- * End Of Input @@ -225,11 +225,15 @@ -- @ -- {-# INLINE CONLIKE parseOnly #-} - parseOnly :: Parser a -> Text -> Maybe a + parseOnly :: Parser a -> Text -> Either String a parseOnly par = \inp -> case runParser par inp of - Success res _ -> Just res - _otherwise -> Nothing + Success res _ -> Right res + Error reason _ _ -> Left reason + Failure expected _ -> + case expected of + [] -> Left $ "Unexpected input." + ex -> Left $ "Expected " <> List.intercalate ", " ex <> "." -- | @@ -450,24 +454,6 @@ -- | - -- 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 #-} @@ -480,6 +466,34 @@ case test res of Right res' -> Success res' more Left reason -> Error reason inp (length inp - length more) + + + -- | + -- Given list of matchers and parsers, runs the first parser whose matcher + -- succeeds on the input. This pattern makes for a simpler alternative to + -- @try@ used in other parser combinator libraries. + -- + -- Example: + -- + -- @ + -- pProperty = branch [ ( string "public" <* skipSpace + -- , \_ -> Property Public <$> pToken + -- ) + -- , ( string "private" <* skipSpace + -- , \_ -> Property Private <$> pToken + -- ) + -- ] + -- @ + -- + {-# INLINE CONLIKE branch #-} + branch :: [(Parser a, a -> Parser b)] -> Parser b + branch [] = Parser \inp -> Failure [] inp + branch ((Parser test, finish) : alts) = + Parser \inp -> + case test inp of + Success res more -> runParser (finish res) more + Error reason more len -> Error reason more len + Failure _expected _more -> runParser (branch alts) inp -- | diff --git a/lib/Data/Text/Parser.hs-boot b/lib/Data/Text/Parser.hs-boot --- a/lib/Data/Text/Parser.hs-boot +++ b/lib/Data/Text/Parser.hs-boot @@ -1,6 +1,7 @@ module Data.Text.Parser where import Control.Applicative + import Control.Monad import Data.Text (Text) data Result a @@ -19,3 +20,4 @@ instance Applicative Parser instance Alternative Parser instance Monad Parser + instance MonadPlus Parser diff --git a/snack.cabal b/snack.cabal --- a/snack.cabal +++ b/snack.cabal @@ -1,12 +1,12 @@ cabal-version: 3.0 name: snack -version: 0.3.0.0 +version: 0.4.0.0 license: CC0-1.0 license-file: LICENSE copyright: Jan Hamal Dvořák maintainer: mordae@anilinux.org author: Jan Hamal Dvořák -tested-with: ghc ==9.2.1 ghc ==9.0.2 ghc ==8.10.7 +tested-with: ghc ==9.2.1 homepage: https://github.com/mordae/snack#readme bug-reports: https://github.com/mordae/snack/issues synopsis: Strict ByteString Parser Combinator