diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,8 @@ On hackage: http://hackage.haskell.org/package/scanner +On stackage: https://www.stackage.org/package/scanner + It is often convinient to use backtracking to parse some sophisticated input. Unfortunately it kills performance, so usually you should avoid backtracking. diff --git a/bench/bench.hs b/bench/bench.hs --- a/bench/bench.hs +++ b/bench/bench.hs @@ -9,11 +9,13 @@ import qualified Redis.Reply as Redis import qualified Redis.Atto +import qualified Redis.Zepto import qualified Redis.Scanner import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Attoparsec.Zepto as Zepto import qualified Data.Serialize.Get as Cereal import Criterion @@ -26,19 +28,27 @@ intInput = ":123\r\n" bulkInput = "$10\r\n0123456789\r\n" multiInput = "*3\r\n+A\r\n+B\r\n+C\r\n" - binaryInput = ByteString.pack [5, 65, 66, 67, 68, 69] + binaryInput = + let str = ByteString.pack [5, 65, 66, 67, 68, 69] + in ByteString.concat (replicate 10 str) print (stringAtto smallStringInput) print (stringScanner smallStringInput) print (stringWordScanner smallStringInput) print (redisByteStringReply smallStringInput) print (redisAttoReply smallStringInput) + print (redisZeptoReply smallStringInput) print (redisScannerReply smallStringInput) print (redisAttoReply intInput) + print (redisZeptoReply intInput) print (redisScannerReply intInput) print (redisAttoReply bulkInput) + print (redisZeptoReply bulkInput) print (redisScannerReply bulkInput) print (redisAttoReply multiInput) + print (redisZeptoReply multiInput) print (redisScannerReply multiInput) + print (binaryScanner binaryInput) + print (binaryCereal binaryInput) defaultMain [ bgroup "scanner" [ bgroup "string" @@ -51,27 +61,32 @@ , bgroup "redis" [ bgroup "small string" [ bench "Atto" $ whnf redisAttoReply smallStringInput + , bench "Zepto" $ whnf redisZeptoReply smallStringInput , bench "Scanner" $ whnf redisScannerReply smallStringInput , bench "ByteString" $ whnf redisByteStringReply smallStringInput ] , bgroup "long string" [ bench "Atto" $ whnf redisAttoReply longStringInput + , bench "Zepto" $ whnf redisZeptoReply longStringInput , bench "Scanner" $ whnf redisScannerReply longStringInput , bench "ByteString" $ whnf redisByteStringReply longStringInput ] , bgroup "integer" [ bench "Atto" $ whnf redisAttoReply intInput + , bench "Zepto" $ whnf redisZeptoReply intInput , bench "Scanner" $ whnf redisScannerReply intInput ] , bgroup "bulk" [ bench "Atto" $ whnf redisAttoReply bulkInput + , bench "Zepto" $ whnf redisZeptoReply bulkInput , bench "Scanner" $ whnf redisScannerReply bulkInput ] , bgroup "multi" [ bench "Atto" $ whnf redisAttoReply multiInput + , bench "Zepto" $ whnf redisZeptoReply multiInput , bench "Scanner" $ whnf redisScannerReply multiInput ] ] @@ -117,6 +132,10 @@ Atto.Fail _ _ err -> Left err Atto.Partial _ -> Left "Not enough input" +{-# NOINLINE redisZeptoReply #-} +redisZeptoReply :: ByteString -> Either String Redis.Reply +redisZeptoReply = Zepto.parse Redis.Zepto.reply + {-# NOINLINE redisScannerReply #-} redisScannerReply :: ByteString -> Either String Redis.Reply redisScannerReply bs = case Scanner.scan Redis.Scanner.reply bs of @@ -141,19 +160,45 @@ _ -> Left "Unknown type" Nothing -> Left "Not enought input" -binaryScanner :: ByteString -> Either String ByteString -binaryScanner bs = case Scanner.scan p bs of +binaryScanner :: ByteString -> Either String [ByteString] +binaryScanner bs = case Scanner.scan p' bs of Scanner.Done _ r -> Right r Scanner.Fail _ err -> Left err Scanner.More _ -> Left "Not enought input" where + p' = do + a0 <- p + a1 <- p + a2 <- p + a3 <- p + a4 <- p + a5 <- p + a6 <- p + a7 <- p + a8 <- p + a9 <- p + return [a0, a1, a2, a3, a4, a5, a6, a7, a8, a9] + {-# INLINE p #-} p = do n <- fromIntegral <$> Scanner.anyWord8 Scanner.take n -binaryCereal :: ByteString -> Either String ByteString -binaryCereal bs = Cereal.runGet g bs +binaryCereal :: ByteString -> Either String [ByteString] +binaryCereal bs = Cereal.runGet g' bs where + g' = do + a0 <- g + a1 <- g + a2 <- g + a3 <- g + a4 <- g + a5 <- g + a6 <- g + a7 <- g + a8 <- g + a9 <- g + return [a0, a1, a2, a3, a4, a5, a6, a7, a8, a9] + {-# INLINE g #-} g = do n <- fromIntegral <$> Cereal.getWord8 - Cereal.getByteString n + Cereal.getBytes n diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +0.3 + +* add foldWhile, foldWhile1, satisfy, satisfyMaybe 0.2 diff --git a/examples/Redis/Zepto.hs b/examples/Redis/Zepto.hs new file mode 100644 --- /dev/null +++ b/examples/Redis/Zepto.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Redis.Zepto +( reply +) +where + +import Redis.Reply + +import Prelude hiding (error) +import Data.ByteString (ByteString) +import Data.Attoparsec.Zepto (Parser) +import qualified Data.Attoparsec.Zepto as Zepto +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Read as Text +import Control.Monad + +{-# INLINE reply #-} +reply :: Parser Reply +reply = do + c <- Zepto.take 1 + case c of + "+" -> string + "-" -> error + ":" -> integer + "$" -> bulk + "*" -> multi + _ -> fail "Unknown reply type" + +{-# INLINE string #-} +string :: Parser Reply +string = String <$> line + +{-# INLINE error #-} +error :: Parser Reply +error = Error <$> line + +{-# INLINE integer #-} +integer :: Parser Reply +integer = Integer <$> integral + +{-# INLINE integral #-} +integral :: Integral i => Parser i +integral = do + str <- line + case Text.signed Text.decimal (Text.decodeUtf8 str) of + Left err -> fail (show err) + Right (l, _) -> return l + +{-# INLINE bulk #-} +bulk :: Parser Reply +bulk = Bulk <$> do + len <- integral + if len < 0 + then return Nothing + else Just <$> Zepto.take len <* eol + +-- don't inline it to break the circle between reply and multi +{-# NOINLINE multi #-} +multi :: Parser Reply +multi = Multi <$> do + len <- integral + if len < 0 + then return Nothing + else Just <$> replicateM len reply + +{-# INLINE line #-} +line :: Parser ByteString +line = Zepto.takeWhile (/= 13) <* eol + +{-# INLINE eol #-} +eol :: Parser () +eol = Zepto.string "\r\n" diff --git a/lib/Scanner.hs b/lib/Scanner.hs --- a/lib/Scanner.hs +++ b/lib/Scanner.hs @@ -27,6 +27,11 @@ , skipSpace , lookAhead , lookAheadChar8 +, foldlWhile +, foldlWhile1 +, satisfy +, satisfyMaybe +, decimal ) where diff --git a/lib/Scanner/Internal.hs b/lib/Scanner/Internal.hs --- a/lib/Scanner/Internal.hs +++ b/lib/Scanner/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes, BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} -- | Scanner implementation @@ -11,6 +11,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString (unsafeDrop) +import qualified Scanner.OctetPredicates as OctetPredicates import Control.Monad -- | CPS scanner without backtracking @@ -169,3 +170,73 @@ case ByteString.uncons bs of Just (c, _) -> next bs (Just c) _ -> next ByteString.empty Nothing + +{-| Fold over the octets, which satisfy the predicate -} +{-# INLINE foldlWhile #-} +foldlWhile :: (Word8 -> Bool) -> (a -> Word8 -> a) -> a -> Scanner a +foldlWhile p step init = Scanner $ \ bs next -> let + (l, r) = ByteString.span p bs + state = ByteString.foldl' step init l + in if ByteString.null r + then More $ \ bs -> if ByteString.null bs + then next ByteString.empty state + else run (loop state) bs next + else next r state + where + loop state = do + chunk <- takeChunk state + if ByteString.null chunk + then return state + else do + done <- endOfInput + if done + then return state + else loop (ByteString.foldl' step state chunk) + takeChunk state = Scanner $ \ bs next -> + let (l, r) = ByteString.span p bs + in next r l + +{-| Fold over the octets, which satisfy the predicate, ensuring that there's at least one -} +{-# INLINE foldlWhile1 #-} +foldlWhile1 :: (Word8 -> Bool) -> (a -> Word8 -> a) -> a -> Scanner a +foldlWhile1 predicate step init = do + head <- satisfy predicate + foldlWhile predicate step (step init head) + +{-| Consume a single octet which satisfies the predicate and fail if it does not -} +{-# INLINE satisfy #-} +satisfy :: (Word8 -> Bool) -> Scanner Word8 +satisfy predicate = Scanner $ \ chunk next -> case ByteString.uncons chunk of + Just (word8, remainder) -> handleHeadAndTail word8 remainder next chunk + Nothing -> More $ \ chunk -> case ByteString.uncons chunk of + Just (word8, remainder) -> handleHeadAndTail word8 remainder next chunk + Nothing -> Fail chunk "No more input" + where + handleHeadAndTail :: Word8 -> ByteString -> (ByteString -> Word8 -> Result r) -> ByteString -> Result r + handleHeadAndTail word8 remainder next chunk = if predicate word8 + then if ByteString.null remainder + then More $ \ chunk -> next chunk word8 + else next remainder word8 + else Fail chunk "Octet doesn't satisfy the predicate" + +{-| Consume a single octet in case it satisfies the predicate -} +{-# INLINE satisfyMaybe #-} +satisfyMaybe :: (Word8 -> Bool) -> Scanner (Maybe Word8) +satisfyMaybe predicate = Scanner $ \ chunk next -> case ByteString.uncons chunk of + Just (word8, remainder) -> handleHeadAndTail word8 remainder next chunk + Nothing -> More $ \ chunk -> case ByteString.uncons chunk of + Just (word8, remainder) -> handleHeadAndTail word8 remainder next chunk + Nothing -> next ByteString.empty Nothing + where + handleHeadAndTail :: Word8 -> ByteString -> (ByteString -> Maybe Word8 -> Result r) -> ByteString -> Result r + handleHeadAndTail word8 remainder next chunk = if predicate word8 + then if ByteString.null remainder + then More $ \ chunk -> next chunk (Just word8) + else next remainder (Just word8) + else next chunk Nothing + +{-| Parse a non-negative decimal number in ASCII -} +{-# INLINE decimal #-} +decimal :: Integral n => Scanner n +decimal = foldlWhile1 OctetPredicates.isDigit step 0 where + step a w = a * 10 + fromIntegral (w - 48) diff --git a/lib/Scanner/OctetPredicates.hs b/lib/Scanner/OctetPredicates.hs new file mode 100644 --- /dev/null +++ b/lib/Scanner/OctetPredicates.hs @@ -0,0 +1,9 @@ +module Scanner.OctetPredicates +where + +import Prelude +import Data.Word + + +isDigit :: Word8 -> Bool +isDigit w = w - 48 <= 9 diff --git a/scanner.cabal b/scanner.cabal --- a/scanner.cabal +++ b/scanner.cabal @@ -1,5 +1,5 @@ name: scanner -version: 0.2 +version: 0.3 synopsis: Fast non-backtracking incremental combinator parsing for bytestrings homepage: https://github.com/Yuras/scanner license: BSD3 @@ -23,6 +23,7 @@ Scanner.Internal other-modules: Prelude Data.Either + Scanner.OctetPredicates build-depends: base <5 , bytestring hs-source-dirs: lib, compat @@ -37,6 +38,8 @@ , bytestring , hspec , scanner + other-modules: Prelude + Data.Either default-language: Haskell2010 benchmark bench @@ -45,6 +48,7 @@ main-is: bench.hs other-modules: Redis.Reply Redis.Atto + Redis.Zepto Redis.Scanner default-language: Haskell2010 build-depends: base