diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for bytesmith +## 0.2.0.0 -- 2019-09-24 + +* Add big-endian word parsers. +* Redo module structure so that encoding-specific functions each + live in their own module. +* Add a lot more functions and attempt to make naming somewhat + consistent. +* Add `delimit`. +* Add `replicate`. +* Add `annotate` and its infix synonym ``. + ## 0.1.0.0 -- 2019-08-22 * First version. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +import Data.Char (ord) +import Data.Primitive (ByteArray) +import Data.Word (Word8) +import Gauge.Main (defaultMain,bench,whnf) + +import qualified Data.Bytes.Parser as P +import qualified Data.Bytes.Parser.Latin as Latin +import qualified GHC.Exts as Exts + +main :: IO () +main = defaultMain + [ bench "decPositiveInteger" $ whnf + (\x -> P.parseByteArray (Latin.decUnsignedInteger ()) x) + encodedBigNumber + ] + +encodedBigNumber :: ByteArray +encodedBigNumber = stringToByteArray $ show $ id @Integer $ + 246246357264327645234627753190240202405243024304504230544 + * + 732345623640035232405249305932503920593209520932095234651 + +stringToByteArray :: String -> ByteArray +stringToByteArray = + Exts.fromList . map (fromIntegral @Int @Word8 . ord) diff --git a/bytesmith.cabal b/bytesmith.cabal --- a/bytesmith.cabal +++ b/bytesmith.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: bytesmith -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Nonresumable byte parser description: Parse bytes as fast as possible. This is a nonresumable parser @@ -19,10 +19,21 @@ library exposed-modules: Data.Bytes.Parser + Data.Bytes.Parser.BigEndian + Data.Bytes.Parser.Ascii + Data.Bytes.Parser.Latin + Data.Bytes.Parser.Unsafe + Data.Bytes.Parser.Utf8 + other-modules: + Data.Bytes.Parser.Internal build-depends: , base >=4.12 && <5 - , byteslice >=0.1.1 && <2 + , bytestring >=0.10.8 && <0.11 + , byteslice >=0.1.3 && <0.2 + , contiguous >= 0.4 && < 0.6 , primitive >=0.7 && <0.8 + , text-short >=0.1.3 && <0.2 + , run-st >=0.1 && <0.2 hs-source-dirs: src ghc-options: -O2 -Wall default-language: Haskell2010 @@ -32,8 +43,26 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs + ghc-options: -Wall -O2 build-depends: , base >=4.12.0.0 && <5 , bytesmith , primitive , byteslice + , tasty-hunit + , tasty + , tasty-quickcheck + +benchmark bench + type: exitcode-stdio-1.0 + build-depends: + , base + , byteslice + , bytestring + , gauge + , primitive + , bytesmith + ghc-options: -Wall -O2 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs diff --git a/src/Data/Bytes/Parser.hs b/src/Data/Bytes/Parser.hs --- a/src/Data/Bytes/Parser.hs +++ b/src/Data/Bytes/Parser.hs @@ -16,6 +16,10 @@ {-# language UnboxedSums #-} {-# language UnboxedTuples #-} +-- | Parse non-resumable sequence of bytes. To parse a byte sequence +-- as text, use the @Ascii@, @Latin@, and @Utf8@ modules instead. +-- Functions for parsing decimal-encoded numbers are found in those +-- modules. module Data.Bytes.Parser ( -- * Types Parser(..) @@ -24,85 +28,79 @@ , parseByteArray , parseBytes , parseBytesST - -- * Build Parsers - , fail - , peekAnyAscii - , ascii - , ascii3 - , ascii4 + -- * One Byte , any - , anyAscii - , anyAscii# - , anyUtf8# - , anyAsciiOpt - , decWord - , decWord8 - , decWord16 - , decWord32 - , hexWord16 - , decPositiveInteger + -- * Many Bytes + , take + , takeWhile + -- * Skip + , skipWhile + -- * Match + , byteArray + , bytes + -- * End of Input , endOfInput , isEndOfInput - , skipUntilAsciiConsume - , skipWhile - , skipAscii - , skipAscii1 - , skipAlphaAscii - , skipAlphaAscii1 - , skipDigitsAscii - , skipDigitsAscii1 + , remaining + -- * Control Flow + , fail + , orElse + , annotate + , () + -- * Repetition + , replicate + -- * Subparsing + , delimit + , measure -- * Lift Effects , effect - -- * Expose Internals - , cursor - , expose - , unconsume - -- * Cut down on boxing - , unboxWord32 + -- * Box Result , boxWord32 + , boxIntPair + -- * Unbox Result + , unboxWord32 + , unboxIntPair -- * Specialized Bind - -- $bind - , bindChar - -- * Alternative - , orElse + -- | Sometimes, GHC ends up building join points in a way that + -- boxes arguments unnecessarily. In this situation, special variants + -- of monadic @>>=@ can be helpful. If @C#@, @I#@, etc. never + -- get used in your original source code, GHC will not introduce them. + , bindFromCharToLifted + , bindFromLiftedToIntPair + , bindFromLiftedToInt + , bindFromIntToIntPair + , bindFromCharToIntPair + , bindFromMaybeCharToIntPair + , bindFromMaybeCharToLifted + -- * Specialized Pure + , pureIntPair + -- * Specialized Fail + , failIntPair ) where -import Prelude hiding (length,any,fail) +import Prelude hiding (length,any,fail,takeWhile,take,replicate) -import Data.Char (ord) -import Data.Bits ((.&.),(.|.),unsafeShiftL,xor) -import Data.Kind (Type) -import GHC.ST (ST(..),runST) -import GHC.Exts (Word(W#),Word#,TYPE,State#,Int#,ByteArray#) -import GHC.Exts (Int(I#),Char(C#),chr#,RuntimeRep) -import GHC.Exts (Char#,(+#),(-#),(<#),(>#),word2Int#) -import GHC.Exts (indexCharArray#,indexWord8Array#,ord#) -import GHC.Exts (timesWord#,plusWord#) -import GHC.Word (Word16(W16#),Word8(W8#),Word32(W32#)) +import Data.Bytes.Parser.Internal (InternalResult(..),Parser(..),unboxBytes,boxBytes,Result#,uneffectful,fail) +import Data.Bytes.Parser.Unsafe (unconsume) import Data.Bytes.Types (Bytes(..)) import Data.Primitive (ByteArray(..)) +import GHC.Exts (Int(I#),Word#,Int#,Char#,(+#),(-#),(>=#)) +import GHC.ST (ST(..),runST) +import GHC.Word (Word32(W32#),Word8) +import Data.Primitive.Contiguous (Contiguous,Element) +import qualified Data.Bytes as B import qualified Data.Primitive as PM -import qualified Control.Monad - -type Bytes# = (# ByteArray#, Int#, Int# #) -type ST# s (a :: TYPE r) = State# s -> (# State# s, a #) -type Result# e (a :: TYPE r) = - (# e - | (# a, Int#, Int# #) #) -- ints are offset and length - --- | A non-resumable parser. -newtype Parser :: forall (r :: RuntimeRep). Type -> Type -> TYPE r -> Type where - Parser :: forall (r :: RuntimeRep) (e :: Type) (s :: Type) (a :: TYPE r). - { runParser :: (# ByteArray#, Int#, Int# #) -> ST# s (Result# e a) } -> Parser e s a +import qualified Data.Primitive.Contiguous as C -- | The result of running a parser. data Result e a = Failure e -- ^ An error message indicating what went wrong. - | Success !a !Int !Int - -- ^ The parsed value, the offset after the last consumed byte, and the - -- number of bytes remaining in parsed slice. + | Success !a !Int + -- ^ The parsed value and the number of bytes + -- remaining in parsed slice. + deriving (Eq,Show) -- | Parse a slice of a byte array. This can succeed even if the -- entire slice was not consumed by the parser. @@ -113,7 +111,7 @@ action = case p @s of Parser f -> ST (\s0 -> case f (unboxBytes b) s0 of - (# s1, r #) -> (# s1, boxResult r #) + (# s1, r #) -> (# s1, boxPublicResult r #) ) -- | Variant of 'parseBytes' that accepts an unsliced 'ByteArray'. @@ -126,97 +124,9 @@ parseBytesST :: Parser e s a -> Bytes -> ST s (Result e a) parseBytesST (Parser f) !b = ST (\s0 -> case f (unboxBytes b) s0 of - (# s1, r #) -> (# s1, boxResult r #) + (# s1, r #) -> (# s1, boxPublicResult r #) ) -instance Functor (Parser e s) where - {-# inline fmap #-} - fmap f (Parser g) = Parser - (\x s0 -> case g x s0 of - (# s1, r #) -> case r of - (# e | #) -> (# s1, (# e | #) #) - (# | (# a, b, c #) #) -> (# s1, (# | (# f a, b, c #) #) #) - ) - -instance Applicative (Parser e s) where - pure = pureParser - (<*>) = Control.Monad.ap - -instance Monad (Parser e s) where - {-# inline return #-} - {-# inline (>>=) #-} - return = pureParser - Parser f >>= g = Parser - (\x@(# arr, _, _ #) s0 -> case f x s0 of - (# s1, r0 #) -> case r0 of - (# e | #) -> (# s1, (# e | #) #) - (# | (# y, b, c #) #) -> - runParser (g y) (# arr, b, c #) s1 - ) - -pureParser :: a -> Parser e s a -pureParser a = Parser - (\(# _, b, c #) s -> (# s, (# | (# a, b, c #) #) #)) - -upcastUnitSuccess :: (# Int#, Int# #) -> Result# e () -upcastUnitSuccess (# b, c #) = (# | (# (), b, c #) #) - -upcastWordResult :: Result# e Word# -> Result# e Word -upcastWordResult (# e | #) = (# e | #) -upcastWordResult (# | (# a, b, c #) #) = (# | (# W# a, b, c #) #) - --- Precondition: the word is small enough -upcastWord16Result :: Result# e Word# -> Result# e Word16 -upcastWord16Result (# e | #) = (# e | #) -upcastWord16Result (# | (# a, b, c #) #) = (# | (# W16# a, b, c #) #) - --- Precondition: the word is small enough -upcastWord32Result :: Result# e Word# -> Result# e Word32 -upcastWord32Result (# e | #) = (# e | #) -upcastWord32Result (# | (# a, b, c #) #) = (# | (# W32# a, b, c #) #) - --- Precondition: the word is small enough -upcastWord8Result :: Result# e Word# -> Result# e Word8 -upcastWord8Result (# e | #) = (# e | #) -upcastWord8Result (# | (# a, b, c #) #) = (# | (# W8# a, b, c #) #) - -c2w :: Char -> Word8 -c2w = fromIntegral . ord - --- | Get the current offset into the chunk. Using this makes --- it possible to observe the internal difference between 'Bytes' --- that refer to equivalent slices. Be careful. -cursor :: Parser e s Int -cursor = uneffectful $ \chunk -> - Success (offset chunk) (offset chunk) (length chunk) - --- | Return the byte array being parsed. This includes bytes --- that preceed the current offset and may include bytes that --- go beyond the length. This is somewhat dangerous, so only --- use this is you know what you're doing. -expose :: Parser e s ByteArray -expose = uneffectful $ \chunk -> - Success (array chunk) (offset chunk) (length chunk) - --- | Move the cursor back by @n@ bytes. Precondition: you --- must have previously consumed at least @n@ bytes. -unconsume :: Int -> Parser e s () -unconsume n = uneffectful $ \chunk -> - Success () (offset chunk - n) (length chunk + n) - -uneffectful :: (Bytes -> Result e a) -> Parser e s a -{-# inline uneffectful #-} -uneffectful f = Parser - ( \b s0 -> (# s0, unboxResult (f (boxBytes b)) #) ) - -uneffectful# :: (Bytes -> Result# e a) -> Parser e s a -uneffectful# f = Parser - ( \b s0 -> (# s0, (f (boxBytes b)) #) ) - -uneffectfulWord# :: (Bytes -> Result# e Word#) -> Parser e s Word# -uneffectfulWord# f = Parser - ( \b s0 -> (# s0, (f (boxBytes b)) #) ) - -- | Lift an effectful computation into a parser. effect :: ST s a -> Parser e s a effect (ST f) = Parser @@ -224,59 +134,29 @@ (# s1, a #) -> (# s1, (# | (# a, off, len #) #) #) ) --- | Only valid for characters with a Unicode code point lower --- than 128. This consumes a single byte, decoding it as an ASCII --- character. -ascii :: e -> Char -> Parser e s () --- GHC should decide to inline this after optimization. -ascii e !c = uneffectful $ \chunk -> if length chunk > 0 - then if PM.indexByteArray (array chunk) (offset chunk) == c2w c - then Success () (offset chunk + 1) (length chunk - 1) - else Failure e - else Failure e +byteArray :: e -> ByteArray -> Parser e s () +byteArray e !expected = bytes e (B.fromByteArray expected) --- | Parse three bytes in succession. -ascii3 :: e -> Char -> Char -> Char -> Parser e s () --- GHC should decide to inline this after optimization. -ascii3 e !c0 !c1 !c2 = uneffectful $ \chunk -> - if | length chunk > 2 - , PM.indexByteArray (array chunk) (offset chunk) == c2w c0 - , PM.indexByteArray (array chunk) (offset chunk + 1) == c2w c1 - , PM.indexByteArray (array chunk) (offset chunk + 2) == c2w c2 - -> Success () (offset chunk + 3) (length chunk - 3) - | otherwise -> Failure e +bytes :: e -> Bytes -> Parser e s () +bytes e !expected = Parser + ( \actual@(# _, off, len #) s -> + let r = if B.isPrefixOf expected (boxBytes actual) + then let !(I# movement) = length expected in + (# | (# (), off +# movement, len -# movement #) #) + else (# e | #) + in (# s, r #) + ) --- | Parse four bytes in succession. -ascii4 :: e -> Char -> Char -> Char -> Char -> Parser e s () --- GHC should decide to inline this after optimization. -ascii4 e !c0 !c1 !c2 !c3 = uneffectful $ \chunk -> - if | length chunk > 3 - , PM.indexByteArray (array chunk) (offset chunk) == c2w c0 - , PM.indexByteArray (array chunk) (offset chunk + 1) == c2w c1 - , PM.indexByteArray (array chunk) (offset chunk + 2) == c2w c2 - , PM.indexByteArray (array chunk) (offset chunk + 3) == c2w c3 - -> Success () (offset chunk + 4) (length chunk - 4) - | otherwise -> Failure e +infix 0 --- | Fail with the provided error message. -fail :: - e -- ^ Error message - -> Parser e s a -fail e = uneffectful $ \_ -> Failure e +-- | Infix version of 'annotate'. +() :: Parser x s a -> e -> Parser e s a +() = annotate --- | Interpret the next byte as an ASCII-encoded character. --- Fails if the byte corresponds to a number above 127. -peekAnyAscii :: e -> Parser e s Char -peekAnyAscii e = uneffectful $ \chunk -> if length chunk > 0 - then - let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 - in if w < 128 - then Success - (C# (chr# (unI (fromIntegral w)))) - (offset chunk) - (length chunk) - else Failure e - else Failure e +-- | Annotate a parser. If the parser fails, the error will +-- be returned. +annotate :: Parser x s a -> e -> Parser e s a +annotate p e = p `orElse` fail e -- | Consumes and returns the next byte in the input. -- Fails if no characters are left. @@ -285,8 +165,8 @@ any e = uneffectful $ \chunk -> if length chunk > 0 then let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 - in Success w (offset chunk + 1) (length chunk - 1) - else Failure e + in InternalSuccess w (offset chunk + 1) (length chunk - 1) + else InternalFailure e -- Interpret the next byte as an ASCII-encoded character. -- Does not check to see if any characters are left. This @@ -295,91 +175,28 @@ {-# inline anyUnsafe #-} anyUnsafe = uneffectful $ \chunk -> let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 - in Success w (offset chunk + 1) (length chunk - 1) - --- | Interpret the next byte as an ASCII-encoded character. --- Fails if the byte corresponds to a number above 127. -anyAscii :: e -> Parser e s Char -{-# inline anyAscii #-} -anyAscii e = uneffectful $ \chunk -> if length chunk > 0 - then - let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 - in if w < 128 - then Success - (C# (chr# (unI (fromIntegral w)))) - (offset chunk + 1) - (length chunk - 1) - else Failure e - else Failure e + in InternalSuccess w (offset chunk + 1) (length chunk - 1) --- | Interpret the next byte as an ASCII-encoded character. --- Fails if the byte corresponds to a number above 127. -anyAscii# :: e -> Parser e s Char# -{-# inline anyAscii# #-} -anyAscii# e = Parser - (\(# arr, off, len #) s0 -> case len of - 0# -> (# s0, (# e | #) #) - _ -> - let !w = indexCharArray# arr off - in case ord# w <# 128# of - 1# -> (# s0, (# | (# w, off +# 1#, len -# 1# #) #) #) - _ -> (# s0, (# e | #) #) - ) +-- | Take while the predicate is matched. This is always inlined. +takeWhile :: (Word8 -> Bool) -> Parser e s Bytes +{-# inline takeWhile #-} +takeWhile f = uneffectful $ \chunk -> case B.takeWhile f chunk of + bs -> InternalSuccess bs (offset chunk + length bs) (length chunk - length bs) --- | Interpret the next one to four bytes as a UTF-8-encoded character. --- Fails if the decoded codepoint is in the range U+D800 through U+DFFF. -anyUtf8# :: e -> Parser e s Char# -{-# noinline anyUtf8# #-} -anyUtf8# e = Parser - (\(# arr, off, len #) s0 -> case len ># 0# of - 1# -> - let !w0 = indexWord8Array# arr off - in if | oneByteChar (W8# w0) -> - (# s0, (# | (# chr# (word2Int# w0), off +# 1#, len -# 1# #) #) #) - | twoByteChar (W8# w0) -> - if | I# len > 1 - , w1 <- indexWord8Array# arr (off +# 1#) - , followingByte (W8# w1) - , C# c <- codepointFromTwoBytes (W8# w0) (W8# w1) - -> (# s0, (# | (# c, off +# 2#, len -# 2# #) #) #) - | otherwise -> (# s0, (# e | #) #) - | threeByteChar (W8# w0) -> - if | I# len > 2 - , w1 <- indexWord8Array# arr (off +# 1# ) - , w2 <- indexWord8Array# arr (off +# 2# ) - , followingByte (W8# w1) - , !c@(C# c#) <- codepointFromThreeBytes (W8# w0) (W8# w1) (W8# w2) - , c < '\xD800' || c > '\xDFFF' - -> (# s0, (# | (# c#, off +# 3#, len -# 3# #) #) #) - | otherwise -> (# s0, (# e | #) #) - | fourByteChar (W8# w0) -> - if | I# len > 3 - , w1 <- indexWord8Array# arr (off +# 1# ) - , w2 <- indexWord8Array# arr (off +# 2# ) - , w3 <- indexWord8Array# arr (off +# 3# ) - , followingByte (W8# w1) - , !(C# c#) <- codepointFromFourBytes (W8# w0) (W8# w1) (W8# w2) (W8# w3) - -> (# s0, (# | (# c#, off +# 4#, len -# 4# #) #) #) - | otherwise -> (# s0, (# e | #) #) - | otherwise -> (# s0, (# e | #) #) - _ -> (# s0, (# e | #) #) - ) +-- | Take the given number of bytes. Fails if there is not enough +-- remaining input. +take :: e -> Int -> Parser e s Bytes +{-# inline take #-} +take e n = uneffectful $ \chunk -> if n <= B.length chunk + then case B.unsafeTake n chunk of + bs -> InternalSuccess bs (offset chunk + n) (length chunk - n) + else InternalFailure e --- | Interpret the next byte as an ASCII-encoded character. --- Fails if the byte corresponds to a number above 127. Returns --- nothing if the end of the input has been reached. -anyAsciiOpt :: e -> Parser e s (Maybe Char) -{-# inline anyAsciiOpt #-} -anyAsciiOpt e = uneffectful $ \chunk -> if length chunk > 0 - then - let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 - in if w < 128 - then Success - (Just (C# (chr# (unI (fromIntegral w))))) - (offset chunk + 1) - (length chunk - 1) - else Failure e - else Success Nothing (offset chunk) (length chunk) +-- | Consume all remaining bytes in the input. +remaining :: Parser e s Bytes +{-# inline remaining #-} +remaining = uneffectful $ \chunk -> + InternalSuccess chunk (offset chunk + length chunk) 0 -- | Skip while the predicate is matched. This is always inlined. skipWhile :: (Word8 -> Bool) -> Parser e s () @@ -393,345 +210,27 @@ then go else unconsume 1 --- | Parse exactly four ASCII-encoded characters, interpretting --- them as the hexadecimal encoding of a 32-bit number. Note that --- this rejects a sequence such as @5A9@, requiring @05A9@ instead. --- This is insensitive to case. -hexWord16 :: e -> Parser e s Word16 -{-# inline hexWord16 #-} -hexWord16 e = Parser - (\x s0 -> case runParser (hexWord16# e) x s0 of - (# s1, r #) -> case r of - (# err | #) -> (# s1, (# err | #) #) - (# | (# a, b, c #) #) -> (# s1, (# | (# W16# a, b, c #) #) #) - ) -hexWord16# :: e -> Parser e s Word# -{-# noinline hexWord16# #-} -hexWord16# e = uneffectfulWord# $ \chunk -> if length chunk >= 4 - then - let !w0@(W# n0) = oneHex $ PM.indexByteArray (array chunk) (offset chunk) - !w1@(W# n1) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 1) - !w2@(W# n2) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 2) - !w3@(W# n3) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 3) - in if | w0 .|. w1 .|. w2 .|. w3 /= maxBound -> - (# | - (# (n0 `timesWord#` 4096##) `plusWord#` - (n1 `timesWord#` 256##) `plusWord#` - (n2 `timesWord#` 16##) `plusWord#` - n3 - , unI (offset chunk) +# 4# - , unI (length chunk) -# 4# #) #) - | otherwise -> (# e | #) - else (# e | #) - - --- Returns the maximum machine word if the argument is not --- the ASCII encoding of a hexadecimal digit. -oneHex :: Word8 -> Word -oneHex w - | w >= 48 && w < 58 = (fromIntegral w - 48) - | w >= 65 && w < 71 = (fromIntegral w - 55) - | w >= 97 && w < 103 = (fromIntegral w - 87) - | otherwise = maxBound - --- | Skip ASCII-encoded digits until a non-digit is encountered. -skipDigitsAscii :: Parser e s () -skipDigitsAscii = uneffectful# $ \c -> - upcastUnitSuccess (skipDigitsAsciiLoop c) - --- | Skip uppercase and lowercase letters until a non-alpha --- character is encountered. -skipDigitsAscii1 :: e -> Parser e s () -skipDigitsAscii1 e = uneffectful# $ \c -> - skipDigitsAscii1LoopStart e c - --- | Skip uppercase and lowercase letters until a non-alpha --- character is encountered. -skipAlphaAscii :: Parser e s () -skipAlphaAscii = uneffectful# $ \c -> - upcastUnitSuccess (skipAlphaAsciiLoop c) - --- | Skip uppercase and lowercase letters until a non-alpha --- character is encountered. -skipAlphaAscii1 :: e -> Parser e s () -skipAlphaAscii1 e = uneffectful# $ \c -> - skipAlphaAsciiLoop1Start e c - --- | Skip the character any number of times. This succeeds --- even if the character was not present. -skipAscii :: Char -> Parser e s () -skipAscii !w = uneffectful# $ \c -> - upcastUnitSuccess (skipLoop (c2w w) c) - --- | Skip the character any number of times. It must occur --- at least once or else this will fail. -skipAscii1 :: e -> Char -> Parser e s () -skipAscii1 e !w = uneffectful# $ \c -> - skipLoop1Start e (c2w w) c - -skipDigitsAsciiLoop :: - Bytes -- Chunk - -> (# Int#, Int# #) -skipDigitsAsciiLoop !c = if length c > 0 - then - let w = PM.indexByteArray (array c) (offset c) :: Word8 - in if w >= c2w '0' && w <= c2w '9' - then skipDigitsAsciiLoop (advance 1 c) - else (# unI (offset c), unI (length c) #) - else (# unI (offset c), unI (length c) #) - -skipAlphaAsciiLoop :: - Bytes -- Chunk - -> (# Int#, Int# #) -skipAlphaAsciiLoop !c = if length c > 0 - then - let w = PM.indexByteArray (array c) (offset c) :: Word8 - in if (w >= c2w 'a' && w <= c2w 'z') || (w >= c2w 'A' && w <= c2w 'Z') - then skipAlphaAsciiLoop (advance 1 c) - else (# unI (offset c), unI (length c) #) - else (# unI (offset c), unI (length c) #) - -skipAlphaAsciiLoop1Start :: - e - -> Bytes -- chunk - -> Result# e () -skipAlphaAsciiLoop1Start e !c = if length c > 0 - then - let w = PM.indexByteArray (array c) (offset c) :: Word8 - in if (w >= c2w 'a' && w <= c2w 'z') || (w >= c2w 'A' && w <= c2w 'Z') - then upcastUnitSuccess (skipAlphaAsciiLoop (advance 1 c)) - else (# e | #) - else (# e | #) - -skipDigitsAscii1LoopStart :: - e - -> Bytes -- chunk - -> Result# e () -skipDigitsAscii1LoopStart e !c = if length c > 0 - then - let w = PM.indexByteArray (array c) (offset c) :: Word8 - in if w >= c2w '0' && w <= c2w '9' - then upcastUnitSuccess (skipDigitsAsciiLoop (advance 1 c)) - else (# e | #) - else (# e | #) - -skipLoop :: - Word8 -- byte to match - -> Bytes -- Chunk - -> (# Int#, Int# #) -skipLoop !w !c = if length c > 0 - then if PM.indexByteArray (array c) (offset c) == w - then skipLoop w (advance 1 c) - else (# unI (offset c), unI (length c) #) - else (# unI (offset c), unI (length c) #) - -skipLoop1Start :: - e - -> Word8 -- byte to match - -> Bytes -- chunk - -> Result# e () -skipLoop1Start e !w !chunk0 = if length chunk0 > 0 - then if PM.indexByteArray (array chunk0) (offset chunk0) == w - then upcastUnitSuccess (skipLoop w (advance 1 chunk0)) - else (# e | #) - else (# e | #) - --- | Skip bytes until the character from the ASCII plane is encountered. --- This does not ensure that the skipped bytes were ASCII-encoded --- characters. -skipUntilAsciiConsume :: e -> Char -> Parser e s () -skipUntilAsciiConsume e !w = uneffectful# $ \c -> - skipUntilConsumeLoop e (c2w w) c - -skipUntilConsumeLoop :: - e -- Error message - -> Word8 -- byte to match - -> Bytes -- Chunk - -> Result# e () -skipUntilConsumeLoop e !w !c = if length c > 0 - then if PM.indexByteArray (array c) (offset c) /= w - then skipUntilConsumeLoop e w (advance 1 c) - else (# | (# (), unI (offset c + 1), unI (length c - 1) #) #) - else (# e | #) - -- | Fails if there is still more input remaining. endOfInput :: e -> Parser e s () -- GHC should decide to inline this after optimization. endOfInput e = uneffectful $ \chunk -> if length chunk == 0 - then Success () (offset chunk) 0 - else Failure e + then InternalSuccess () (offset chunk) 0 + else InternalFailure e -- | Returns true if there are no more bytes in the input. Returns -- false otherwise. Always succeeds. isEndOfInput :: Parser e s Bool -- GHC should decide to inline this after optimization. isEndOfInput = uneffectful $ \chunk -> - Success (length chunk == 0) (offset chunk) (length chunk) - --- | Parse a decimal-encoded 8-bit word. If the number is larger --- than 255, this parser fails. -decWord8 :: e -> Parser e s Word8 -decWord8 e = Parser - (\chunk0 s0 -> case decSmallWordStart e 256 (boxBytes chunk0) s0 of - (# s1, r #) -> (# s1, upcastWord8Result r #) - ) - --- | Parse a decimal-encoded 16-bit word. If the number is larger --- than 65535, this parser fails. -decWord16 :: e -> Parser e s Word16 -decWord16 e = Parser - (\chunk0 s0 -> case decSmallWordStart e 65536 (boxBytes chunk0) s0 of - (# s1, r #) -> (# s1, upcastWord16Result r #) - ) - --- | Parse a decimal-encoded 32-bit word. If the number is larger --- than 4294967295, this parser fails. -decWord32 :: e -> Parser e s Word32 --- This will not work on 32-bit platforms. -decWord32 e = Parser - (\chunk0 s0 -> case decSmallWordStart e 4294967296 (boxBytes chunk0) s0 of - (# s1, r #) -> (# s1, upcastWord32Result r #) - ) - --- | Parse a decimal-encoded number. If the number is too large to be --- represented by a machine word, this overflows rather than failing. --- This may be changed in a future release. -decWord :: e -> Parser e s Word -decWord e = Parser - (\chunk0 s0 -> case decWordStart e (boxBytes chunk0) s0 of - (# s1, r #) -> (# s1, upcastWordResult r #) - ) - --- | Parse a decimal-encoded positive integer of arbitrary --- size. Note: this is not implemented efficiently. This --- pulls in one digit at a time, multiplying the accumulator --- by ten each time and adding the new digit. Since --- arithmetic involving arbitrary-precision integers is --- somewhat expensive, it would be better to pull in several --- digits at a time, convert those to a machine-sized integer, --- then upcast and perform the multiplication and addition. -decPositiveInteger :: e -> Parser e s Integer -decPositiveInteger e = Parser - (\chunk0 s0 -> decPositiveIntegerStart e (boxBytes chunk0) s0) - -decWordStart :: - e -- Error message - -> Bytes -- Chunk - -> ST# s (Result# e Word# ) -decWordStart e !chunk0 s0 = if length chunk0 > 0 - then - let !w = fromIntegral @Word8 @Word - (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < 10 - then (# s0, decWordMore e w (advance 1 chunk0) #) - else (# s0, (# e | #) #) - else (# s0, (# e | #) #) - --- No limit on length for integers. -decPositiveIntegerStart :: - e - -> Bytes - -> ST# s (Result# e Integer) -decPositiveIntegerStart e !chunk0 s0 = if length chunk0 > 0 - then - let !w = (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < (10 :: Word8) - then (# s0, decIntegerMore e (fromIntegral w) (advance 1 chunk0) #) - else (# s0, (# e | #) #) - else (# s0, (# e | #) #) - -decSmallWordStart :: - e -- Error message - -> Word -- Upper Bound - -> Bytes -- Chunk - -> ST# s (Result# e Word# ) -decSmallWordStart e !limit !chunk0 s0 = if length chunk0 > 0 - then - let !w = fromIntegral @Word8 @Word - (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < 10 - then (# s0, decSmallWordMore e w limit (advance 1 chunk0) #) - else (# s0, (# e | #) #) - else (# s0, (# e | #) #) - --- This will not inline since it is recursive, but worker --- wrapper will still happen. -decWordMore :: - e -- Error message - -> Word -- Accumulator - -> Bytes -- Chunk - -> Result# e Word# -decWordMore e !acc !chunk0 = if length chunk0 > 0 - then - let !w = fromIntegral @Word8 @Word - (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < 10 - then decWordMore e (acc * 10 + w) - (advance 1 chunk0) - else (# | (# unW acc, unI (offset chunk0), unI (length chunk0) #) #) - else (# | (# unW acc, unI (offset chunk0), 0# #) #) - -decSmallWordMore :: - e -- Error message - -> Word -- Accumulator - -> Word -- Upper Bound - -> Bytes -- Chunk - -> Result# e Word# -decSmallWordMore e !acc !limit !chunk0 = if length chunk0 > 0 - then - let !w = fromIntegral @Word8 @Word - (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < 10 - then - let w' = acc * 10 + w - in if w' < limit - then decSmallWordMore e w' limit (advance 1 chunk0) - else (# e | #) - else (# | (# unW acc, unI (offset chunk0), unI (length chunk0) #) #) - else (# | (# unW acc, unI (offset chunk0), 0# #) #) - -decIntegerMore :: - e -- Error message - -> Integer -- Accumulator - -> Bytes -- Chunk - -> Result# e Integer -decIntegerMore e !acc !chunk0 = if length chunk0 > 0 - then - let w :: Word8 - !w = (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 - in if w < 10 - then - let w' = acc * 10 + fromIntegral w - in decIntegerMore e w' (advance 1 chunk0) - else (# | (# acc, unI (offset chunk0), unI (length chunk0) #) #) - else (# | (# acc, unI (offset chunk0), 0# #) #) - -advance :: Int -> Bytes -> Bytes -advance n (Bytes arr off len) = Bytes arr (off + n) (len - n) - -unW :: Word -> Word# -unW (W# w) = w - -unI :: Int -> Int# -unI (I# w) = w - -boxBytes :: Bytes# -> Bytes -boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) - -unboxBytes :: Bytes -> Bytes# -unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) - -unboxResult :: Result e a -> Result# e a -unboxResult (Success a (I# b) (I# c)) = (# | (# a, b, c #) #) -unboxResult (Failure e) = (# e | #) + InternalSuccess (length chunk == 0) (offset chunk) (length chunk) -boxResult :: Result# e a -> Result e a -boxResult (# | (# a, b, c #) #) = Success a (I# b) (I# c) -boxResult (# e | #) = Failure e +boxPublicResult :: Result# e a -> Result e a +boxPublicResult (# | (# a, _, c #) #) = Success a (I# c) +boxPublicResult (# e | #) = Failure e -- | Convert a 'Word32' parser to a 'Word#' parser. -unboxWord32 :: Parser s e Word32 -> Parser s e Word# +unboxWord32 :: Parser e s Word32 -> Parser e s Word# unboxWord32 (Parser f) = Parser (\x s0 -> case f x s0 of (# s1, r #) -> case r of @@ -739,9 +238,18 @@ (# | (# W32# a, b, c #) #) -> (# s1, (# | (# a, b, c #) #) #) ) +-- | Convert a @(Int,Int)@ parser to a @(# Int#, Int# #)@ parser. +unboxIntPair :: Parser e s (Int,Int) -> Parser e s (# Int#, Int# #) +unboxIntPair (Parser f) = Parser + (\x s0 -> case f x s0 of + (# s1, r #) -> case r of + (# e | #) -> (# s1, (# e | #) #) + (# | (# (I# y, I# z), b, c #) #) -> (# s1, (# | (# (# y, z #), b, c #) #) #) + ) + -- | Convert a 'Word#' parser to a 'Word32' parser. Precondition: -- the argument parser only returns words less than 4294967296. -boxWord32 :: Parser s e Word# -> Parser s e Word32 +boxWord32 :: Parser e s Word# -> Parser e s Word32 boxWord32 (Parser f) = Parser (\x s0 -> case f x s0 of (# s1, r #) -> case r of @@ -749,13 +257,26 @@ (# | (# a, b, c #) #) -> (# s1, (# | (# W32# a, b, c #) #) #) ) --- | There is a law-abiding instance of @Alternative@ for 'Parser'. +-- | Convert a @(# Int#, Int# #)@ parser to a @(Int,Int)@ parser. +boxIntPair :: Parser e s (# Int#, Int# #) -> Parser e s (Int,Int) +boxIntPair (Parser f) = Parser + (\x s0 -> case f x s0 of + (# s1, r #) -> case r of + (# e | #) -> (# s1, (# e | #) #) + (# | (# (# y, z #), b, c #) #) -> (# s1, (# | (# (I# y, I# z), b, c #) #) #) + ) + + +-- | There is a law-abiding instance of 'Alternative' for 'Parser'. -- However, it is not terribly useful since error messages seldom --- have a 'Monoid' instance. This function is a right-biased --- variant of @\<|\>@. Consequently, it lacks an identity. --- See +-- have a 'Monoid' instance. This function is a variant of @\<|\>@ +-- that is right-biased in its treatment of error messages. +-- Consequently, @orElse@ lacks an identity. +-- See -- for more discussion of this topic. -orElse :: Parser s e a -> Parser s e a -> Parser s e a +infixl 3 `orElse` +orElse :: Parser x s a -> Parser e s a -> Parser e s a +{-# inline orElse #-} orElse (Parser f) (Parser g) = Parser (\x s0 -> case f x s0 of (# s1, r0 #) -> case r0 of @@ -763,68 +284,75 @@ (# | r #) -> (# s1, (# | r #) #) ) -codepointFromFourBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Char -codepointFromFourBytes w1 w2 w3 w4 = C# - ( chr# - ( unI $ fromIntegral - ( unsafeShiftL (word8ToWord w1 .&. 0b00001111) 18 .|. - unsafeShiftL (word8ToWord w2 .&. 0b00111111) 12 .|. - unsafeShiftL (word8ToWord w3 .&. 0b00111111) 6 .|. - (word8ToWord w4 .&. 0b00111111) - ) - ) +bindFromCharToLifted :: Parser s e Char# -> (Char# -> Parser s e a) -> Parser s e a +{-# inline bindFromCharToLifted #-} +bindFromCharToLifted (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 ) -codepointFromThreeBytes :: Word8 -> Word8 -> Word8 -> Char -codepointFromThreeBytes w1 w2 w3 = C# - ( chr# - ( unI $ fromIntegral - ( unsafeShiftL (word8ToWord w1 .&. 0b00001111) 12 .|. - unsafeShiftL (word8ToWord w2 .&. 0b00111111) 6 .|. - (word8ToWord w3 .&. 0b00111111) - ) - ) +bindFromCharToIntPair :: Parser s e Char# -> (Char# -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #) +{-# inline bindFromCharToIntPair #-} +bindFromCharToIntPair (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 ) -codepointFromTwoBytes :: Word8 -> Word8 -> Char -codepointFromTwoBytes w1 w2 = C# - ( chr# - ( unI $ fromIntegral @Word @Int - ( unsafeShiftL (word8ToWord w1 .&. 0b00011111) 6 .|. - (word8ToWord w2 .&. 0b00111111) - ) - ) +bindFromLiftedToInt :: Parser s e a -> (a -> Parser s e Int#) -> Parser s e Int# +{-# inline bindFromLiftedToInt #-} +bindFromLiftedToInt (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 ) -oneByteChar :: Word8 -> Bool -oneByteChar !w = w .&. 0b10000000 == 0 - -twoByteChar :: Word8 -> Bool -twoByteChar !w = w .&. 0b11100000 == 0b11000000 - -threeByteChar :: Word8 -> Bool -threeByteChar !w = w .&. 0b11110000 == 0b11100000 - -fourByteChar :: Word8 -> Bool -fourByteChar !w = w .&. 0b11111000 == 0b11110000 - -word8ToWord :: Word8 -> Word -word8ToWord = fromIntegral +bindFromLiftedToIntPair :: Parser s e a -> (a -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #) +{-# inline bindFromLiftedToIntPair #-} +bindFromLiftedToIntPair (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 + ) -followingByte :: Word8 -> Bool -followingByte !w = xor w 0b01000000 .&. 0b11000000 == 0b11000000 +bindFromIntToIntPair :: Parser s e Int# -> (Int# -> Parser s e (# Int#, Int# #)) -> Parser s e (# Int#, Int# #) +{-# inline bindFromIntToIntPair #-} +bindFromIntToIntPair (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 + ) -{- $bind -Sometimes, GHC ends up building join points in a way that -boxes arguments unnecessarily. In this situation, special variants -of monadic @>>=@ can be helpful. If @C#@, @I#@, etc. never -get used in you original source code, GHC cannot introduce them. --} +bindFromMaybeCharToIntPair :: + Parser s e (# (# #) | Char# #) + -> ((# (# #) | Char# #) -> Parser s e (# Int#, Int# #)) + -> Parser s e (# Int#, Int# #) +{-# inline bindFromMaybeCharToIntPair #-} +bindFromMaybeCharToIntPair (Parser f) g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 + ) --- | Specialization of monadic bind for parsers that return 'Char#'. -bindChar :: Parser s e Char# -> (Char# -> Parser s e a) -> Parser s e a -{-# inline bindChar #-} -bindChar (Parser f) g = Parser +bindFromMaybeCharToLifted :: + Parser s e (# (# #) | Char# #) + -> ((# (# #) | Char# #) -> Parser s e a) + -> Parser s e a +{-# inline bindFromMaybeCharToLifted #-} +bindFromMaybeCharToLifted (Parser f) g = Parser (\x@(# arr, _, _ #) s0 -> case f x s0 of (# s1, r0 #) -> case r0 of (# e | #) -> (# s1, (# e | #) #) @@ -832,3 +360,73 @@ runParser (g y) (# arr, b, c #) s1 ) +pureIntPair :: + (# Int#, Int# #) + -> Parser s e (# Int#, Int# #) +{-# inline pureIntPair #-} +pureIntPair a = Parser + (\(# _, b, c #) s -> (# s, (# | (# a, b, c #) #) #)) + +failIntPair :: e -> Parser e s (# Int#, Int# #) +{-# inline failIntPair #-} +failIntPair e = Parser + (\(# _, _, _ #) s -> (# s, (# e | #) #)) + +-- | Augment a parser with the number of bytes that were consume while +-- it executed. +measure :: Parser e s a -> Parser e s (Int,a) +{-# inline measure #-} +measure (Parser f) = Parser + (\x@(# _, pre, _ #) s0 -> case f x s0 of + (# s1, r #) -> case r of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, post, c #) #) -> (# s1, (# | (# (I# (post -# pre), y),post,c #) #) #) + ) + +-- | Run a parser in a delimited context, failing if the requested number +-- of bytes are not available or if the delimited parser does not +-- consume all input. This combinator can be understood as a composition +-- of 'take', 'effect', 'parseBytesST', and 'endOfInput'. It is provided as +-- a single combinator because for convenience and because it is easy +-- make mistakes when manually assembling the aforementioned parsers. +-- The pattern of prefixing an encoding with its length is common. +-- This is discussed more in +-- . +-- +-- > delimit e1 e2 n remaining === take e1 n +delimit :: + e -- ^ Error message when not enough bytes are present + -> e -- ^ Error message when delimited parser does not consume all input + -> Int -- ^ Exact number of bytes delimited parser is expected to consume + -> Parser e s a -- ^ Parser to execute in delimited context + -> Parser e s a +delimit esz eleftovers (I# n) (Parser f) = Parser + ( \(# arr, off, len #) s0 -> case len >=# n of + 1# -> case f (# arr, off, n #) s0 of + (# s1, r #) -> case r of + (# e | #) -> (# s1, (# e | #) #) + (# | (# a, newOff, leftovers #) #) -> case leftovers of + 0# -> (# s1, (# | (# a, newOff, len -# n #) #) #) + _ -> (# s1, (# eleftovers | #) #) + _ -> (# s0, (# esz | #) #) + ) + +-- | Replicate a parser @n@ times, writing the results into +-- an array of length @n@. For @Array@ and @SmallArray@, this +-- is lazy in the elements, so be sure the they result of the +-- parser is evaluated appropriately to avoid unwanted thunks. +replicate :: forall arr e s a. (Contiguous arr, Element arr a) + => Int -- ^ Number of times to run the parser + -> Parser e s a -- ^ Parser + -> Parser e s (arr a) +{-# inline replicate #-} +replicate !len p = do + marr <- effect (C.new len) + let go :: Int -> Parser e s (arr a) + go !ix = if ix < len + then do + a <- p + effect (C.write marr ix a) + go (ix + 1) + else effect (C.unsafeFreeze marr) + go 0 diff --git a/src/Data/Bytes/Parser/Ascii.hs b/src/Data/Bytes/Parser/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/Ascii.hs @@ -0,0 +1,195 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +-- | Parse input as ASCII-encoded text. Some parsers in this module, +-- like 'any' and 'peek', fail if they encounter a byte above @0x7F@. +-- Others, like numeric parsers and skipping parsers, leave the cursor +-- at the position of the offending byte without failing. +module Data.Bytes.Parser.Ascii + ( -- * Matching + Latin.char + , Latin.char2 + , Latin.char3 + , Latin.char4 + -- * Get Character + , any + , any# + , peek + , opt + -- * Match Many + , shortTrailedBy + -- * Skip + , Latin.skipDigits + , Latin.skipDigits1 + , Latin.skipChar + , Latin.skipChar1 + , skipAlpha + , skipAlpha1 + , skipTrailedBy + -- * Numbers + , Latin.decWord + , Latin.decWord8 + , Latin.decWord16 + , Latin.decWord32 + ) where + +import Prelude hiding (length,any,fail,takeWhile) + +import Data.Bytes.Types (Bytes(..)) +import Data.Bytes.Parser.Internal (Parser(..),uneffectful,Result#,uneffectful#) +import Data.Bytes.Parser.Internal (InternalResult(..),indexLatinCharArray,upcastUnitSuccess) +import Data.Word (Word8) +import Data.Text.Short (ShortText) +import Control.Monad.ST.Run (runByteArrayST) +import GHC.Exts (Int(I#),Char(C#),Int#,Char#,(-#),(+#),(<#),ord#,indexCharArray#,chr#) + +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.Text.Short.Unsafe as TS +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Parser.Latin as Latin +import qualified Data.Bytes.Parser.Unsafe as Unsafe +import qualified Data.Primitive as PM + +-- | Consume input until the trailer is found. Then, consume +-- the trailer as well. This fails if the trailer is not +-- found or if any non-ASCII characters are encountered. +skipTrailedBy :: e -> Char -> Parser e s () +skipTrailedBy e !c = do + let go = do + !d <- any e + if d == c + then pure () + else go + go + +-- | Consume input through the next occurrence of the target +-- character and return the consumed input, excluding the +-- target character, as a 'ShortText'. This fails if it +-- encounters any bytes above @0x7F@. +shortTrailedBy :: e -> Char -> Parser e s ShortText +shortTrailedBy e !c = do + !start <- Unsafe.cursor + skipTrailedBy e c + end <- Unsafe.cursor + src <- Unsafe.expose + let len = end - start - 1 + !r = runByteArrayST $ do + marr <- PM.newByteArray len + PM.copyByteArray marr 0 src start len + PM.unsafeFreezeByteArray marr + pure + $ TS.fromShortByteStringUnsafe + $ byteArrayToShortByteString + $ r + + +-- | Consumes and returns the next character in the input. +any :: e -> Parser e s Char +any e = uneffectful $ \chunk -> if length chunk > 0 + then + let c = indexLatinCharArray (array chunk) (offset chunk) + in if c < '\128' + then InternalSuccess c (offset chunk + 1) (length chunk - 1) + else InternalFailure e + else InternalFailure e + +-- | Variant of 'any' with unboxed result. +any# :: e -> Parser e s Char# +{-# inline any# #-} +any# e = Parser + (\(# arr, off, len #) s0 -> case len of + 0# -> (# s0, (# e | #) #) + _ -> + let !w = indexCharArray# arr off + in case ord# w <# 128# of + 1# -> (# s0, (# | (# w, off +# 1#, len -# 1# #) #) #) + _ -> (# s0, (# e | #) #) + ) + +unI :: Int -> Int# +unI (I# w) = w + +-- | Examine the next byte without consuming it, interpret it as an +-- ASCII-encoded character. This fails if the byte is above @0x7F@ or +-- if the end of input has been reached. +peek :: e -> Parser e s Char +peek e = uneffectful $ \chunk -> if length chunk > 0 + then + let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 + in if w < 128 + then InternalSuccess + (C# (chr# (unI (fromIntegral w)))) + (offset chunk) + (length chunk) + else InternalFailure e + else InternalFailure e + +-- | Consume the next byte, interpreting it as an ASCII-encoded character. +-- Fails if the byte is above @0x7F@. Returns @Nothing@ if the +-- end of the input has been reached. +opt :: e -> Parser e s (Maybe Char) +{-# inline opt #-} +opt e = uneffectful $ \chunk -> if length chunk > 0 + then + let w = PM.indexByteArray (array chunk) (offset chunk) :: Word8 + in if w < 128 + then InternalSuccess + (Just (C# (chr# (unI (fromIntegral w))))) + (offset chunk + 1) + (length chunk - 1) + else InternalFailure e + else InternalSuccess Nothing (offset chunk) (length chunk) + +-- | Skip uppercase and lowercase letters until a non-alpha +-- character is encountered. +skipAlpha :: Parser e s () +skipAlpha = uneffectful# $ \c -> + upcastUnitSuccess (skipAlphaAsciiLoop c) + +-- | Skip uppercase and lowercase letters until a non-alpha +-- character is encountered. +skipAlpha1 :: e -> Parser e s () +skipAlpha1 e = uneffectful# $ \c -> + skipAlphaAsciiLoop1Start e c + +skipAlphaAsciiLoop :: + Bytes -- Chunk + -> (# Int#, Int# #) +skipAlphaAsciiLoop !c = if length c > 0 + then + let w = indexLatinCharArray (array c) (offset c) + in if (w >= 'a' && w <= 'z') || (w >= 'A' && w <= 'Z') + then skipAlphaAsciiLoop (Bytes.unsafeDrop 1 c) + else (# unI (offset c), unI (length c) #) + else (# unI (offset c), unI (length c) #) + +skipAlphaAsciiLoop1Start :: + e + -> Bytes -- chunk + -> Result# e () +skipAlphaAsciiLoop1Start e !c = if length c > 0 + then + let w = indexLatinCharArray (array c) (offset c) + in if (w >= 'a' && w <= 'z') || (w >= 'A' && w <= 'Z') + then upcastUnitSuccess (skipAlphaAsciiLoop (Bytes.unsafeDrop 1 c)) + else (# e | #) + else (# e | #) + +byteArrayToShortByteString :: PM.ByteArray -> BSS.ShortByteString +byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x + diff --git a/src/Data/Bytes/Parser/BigEndian.hs b/src/Data/Bytes/Parser/BigEndian.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/BigEndian.hs @@ -0,0 +1,118 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +-- | Big-endian fixed-width numbers. +module Data.Bytes.Parser.BigEndian + ( -- * Unsigned + word8 + , word16 + , word32 + , word64 + -- * Signed + , int8 + , int16 + , int32 + , int64 + ) where + +import Prelude hiding (length,any,fail,takeWhile) + +import Data.Bits ((.|.),unsafeShiftL) +import Data.Bytes.Types (Bytes(..)) +import Data.Bytes.Parser.Internal (Parser,uneffectful) +import Data.Bytes.Parser.Internal (InternalResult(..)) +import Data.Word (Word8,Word16,Word32,Word64) +import Data.Int (Int8,Int16,Int32,Int64) + +import qualified Data.Bytes.Parser as P +import qualified Data.Primitive as PM + +-- | Unsigned 8-bit word. +word8 :: e -> Parser e s Word8 +word8 = P.any + +-- | Unsigned 16-bit word. +word16 :: e -> Parser e s Word16 +word16 e = uneffectful $ \chunk -> if length chunk >= 2 + then + let wa = PM.indexByteArray (array chunk) (offset chunk) :: Word8 + wb = PM.indexByteArray (array chunk) (offset chunk + 1) :: Word8 + in InternalSuccess + (fromIntegral @Word @Word16 (unsafeShiftL (fromIntegral wa) 8 .|. fromIntegral wb)) + (offset chunk + 2) (length chunk - 2) + else InternalFailure e + +-- | Unsigned 32-bit word. +word32 :: e -> Parser e s Word32 +word32 e = uneffectful $ \chunk -> if length chunk >= 4 + then + let wa = PM.indexByteArray (array chunk) (offset chunk) :: Word8 + wb = PM.indexByteArray (array chunk) (offset chunk + 1) :: Word8 + wc = PM.indexByteArray (array chunk) (offset chunk + 2) :: Word8 + wd = PM.indexByteArray (array chunk) (offset chunk + 3) :: Word8 + in InternalSuccess + (fromIntegral @Word @Word32 + ( unsafeShiftL (fromIntegral wa) 24 .|. + unsafeShiftL (fromIntegral wb) 16 .|. + unsafeShiftL (fromIntegral wc) 8 .|. + fromIntegral wd + ) + ) + (offset chunk + 4) (length chunk - 4) + else InternalFailure e + +-- | Unsigned 64-bit word. +word64 :: e -> Parser e s Word64 +word64 e = uneffectful $ \chunk -> if length chunk >= 8 + then + let wa = PM.indexByteArray (array chunk) (offset chunk) :: Word8 + wb = PM.indexByteArray (array chunk) (offset chunk + 1) :: Word8 + wc = PM.indexByteArray (array chunk) (offset chunk + 2) :: Word8 + wd = PM.indexByteArray (array chunk) (offset chunk + 3) :: Word8 + we = PM.indexByteArray (array chunk) (offset chunk + 4) :: Word8 + wf = PM.indexByteArray (array chunk) (offset chunk + 5) :: Word8 + wg = PM.indexByteArray (array chunk) (offset chunk + 6) :: Word8 + wh = PM.indexByteArray (array chunk) (offset chunk + 7) :: Word8 + in InternalSuccess + ( unsafeShiftL (fromIntegral wa) 56 .|. + unsafeShiftL (fromIntegral wb) 48 .|. + unsafeShiftL (fromIntegral wc) 40 .|. + unsafeShiftL (fromIntegral wd) 32 .|. + unsafeShiftL (fromIntegral we) 24 .|. + unsafeShiftL (fromIntegral wf) 16 .|. + unsafeShiftL (fromIntegral wg) 8 .|. + fromIntegral wh + ) + (offset chunk + 8) (length chunk - 8) + else InternalFailure e + +-- | Signed 8-bit integer. +int8 :: e -> Parser e s Int8 +int8 = fmap fromIntegral . word8 + +-- | Signed 16-bit integer. +int16 :: e -> Parser e s Int16 +int16 = fmap fromIntegral . word16 + +-- | Signed 32-bit integer. +int32 :: e -> Parser e s Int32 +int32 = fmap fromIntegral . word32 + +-- | Signed 64-bit integer. +int64 :: e -> Parser e s Int64 +int64 = fmap fromIntegral . word64 diff --git a/src/Data/Bytes/Parser/Internal.hs b/src/Data/Bytes/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/Internal.hs @@ -0,0 +1,148 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +module Data.Bytes.Parser.Internal + ( Parser(..) + , InternalResult(..) + , Bytes# + , ST# + , Result# + , uneffectful + , uneffectful# + , boxBytes + , unboxBytes + , unboxResult + , fail + , indexLatinCharArray + , upcastUnitSuccess + ) where + +import Prelude hiding (length,any,fail,takeWhile) + +import Control.Applicative (Alternative) +import Data.Primitive (ByteArray(ByteArray)) +import Data.Bytes.Types (Bytes(Bytes)) +import Data.Kind (Type) +import GHC.Exts (TYPE,RuntimeRep,Int(I#),Int#,State#,ByteArray#,Char(C#)) + +import qualified Control.Applicative +import qualified Control.Monad +import qualified GHC.Exts as Exts + +-- | A non-resumable parser. +newtype Parser :: forall (r :: RuntimeRep). Type -> Type -> TYPE r -> Type where + Parser :: forall (r :: RuntimeRep) (e :: Type) (s :: Type) (a :: TYPE r). + { runParser :: (# ByteArray#, Int#, Int# #) -> ST# s (Result# e a) } -> Parser e s a + +-- The result of running a parser. Used internally. +data InternalResult e a + = InternalFailure e + -- An error message indicating what went wrong. + | InternalSuccess !a !Int !Int + -- The parsed value, the offset after the last consumed byte, and the + -- number of bytes remaining in parsed slice. + +uneffectful :: (Bytes -> InternalResult e a) -> Parser e s a +{-# inline uneffectful #-} +uneffectful f = Parser + ( \b s0 -> (# s0, unboxResult (f (boxBytes b)) #) ) + +boxBytes :: Bytes# -> Bytes +{-# inline boxBytes #-} +boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) + +unboxBytes :: Bytes -> Bytes# +{-# inline unboxBytes #-} +unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) + +type Bytes# = (# ByteArray#, Int#, Int# #) +type ST# s (a :: TYPE r) = State# s -> (# State# s, a #) +type Result# e (a :: TYPE r) = + (# e + | (# a, Int#, Int# #) #) -- ints are offset and length + +unboxResult :: InternalResult e a -> Result# e a +unboxResult (InternalSuccess a (I# b) (I# c)) = (# | (# a, b, c #) #) +unboxResult (InternalFailure e) = (# e | #) + +-- | Combines the error messages using '<>' when both +-- parsers fail. +instance Monoid e => Alternative (Parser e s) where + {-# inline empty #-} + {-# inline (<|>) #-} + empty = fail mempty + Parser f <|> Parser g = Parser + (\x s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# eRight | #) -> case g x s1 of + (# s2, r1 #) -> case r1 of + (# eLeft | #) -> (# s2, (# eRight <> eLeft | #) #) + (# | r #) -> (# s2, (# | r #) #) + (# | r #) -> (# s1, (# | r #) #) + ) + +-- | Fail with the provided error message. +fail :: + e -- ^ Error message + -> Parser e s a +fail e = uneffectful $ \_ -> InternalFailure e + +instance Applicative (Parser e s) where + pure = pureParser + (<*>) = Control.Monad.ap + +pureParser :: a -> Parser e s a +pureParser a = Parser + (\(# _, b, c #) s -> (# s, (# | (# a, b, c #) #) #)) + + +instance Monad (Parser e s) where + {-# inline return #-} + {-# inline (>>=) #-} + return = pureParser + Parser f >>= g = Parser + (\x@(# arr, _, _ #) s0 -> case f x s0 of + (# s1, r0 #) -> case r0 of + (# e | #) -> (# s1, (# e | #) #) + (# | (# y, b, c #) #) -> + runParser (g y) (# arr, b, c #) s1 + ) + +instance Functor (Parser e s) where + {-# inline fmap #-} + fmap f (Parser g) = Parser + (\x s0 -> case g x s0 of + (# s1, r #) -> case r of + (# e | #) -> (# s1, (# e | #) #) + (# | (# a, b, c #) #) -> (# s1, (# | (# f a, b, c #) #) #) + ) + +indexLatinCharArray :: ByteArray -> Int -> Char +{-# inline indexLatinCharArray #-} +indexLatinCharArray (ByteArray arr) (I# off) = + C# (Exts.indexCharArray# arr off) + +uneffectful# :: (Bytes -> Result# e a) -> Parser e s a +{-# inline uneffectful# #-} +uneffectful# f = Parser + ( \b s0 -> (# s0, (f (boxBytes b)) #) ) + +upcastUnitSuccess :: (# Int#, Int# #) -> Result# e () +{-# inline upcastUnitSuccess #-} +upcastUnitSuccess (# b, c #) = (# | (# (), b, c #) #) + diff --git a/src/Data/Bytes/Parser/Latin.hs b/src/Data/Bytes/Parser/Latin.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/Latin.hs @@ -0,0 +1,726 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +-- | Parse input as though it were text encoded by +-- ISO 8859-1 (Latin-1). All byte sequences are valid +-- text under ISO 8859-1. +module Data.Bytes.Parser.Latin + ( -- * Matching + -- ** Required + char + , char2 + , char3 + , char4 + -- ** Try + , trySatisfy + , trySatisfyThen + -- * Get Character + , any + , opt + , opt# + -- * Skip + , skipDigits + , skipDigits1 + , skipChar + , skipChar1 + , skipTrailedBy + -- * Numbers + -- ** Decimal + -- *** Unsigned + , decWord + , decWord8 + , decWord16 + , decWord32 + -- *** Signed + , decUnsignedInt + , decUnsignedInt# + , decSignedInt + , decStandardInt + , decTrailingInt + , decTrailingInt# + , decSignedInteger + , decUnsignedInteger + , decTrailingInteger + -- ** Hexadecimal + , hexWord16 + ) where + +import Prelude hiding (length,any,fail,takeWhile) + +import Data.Bits ((.|.)) +import Data.Bytes.Types (Bytes(..)) +import Data.Bytes.Parser.Internal (Parser(..),ST#,uneffectful,Result#,uneffectful#) +import Data.Bytes.Parser.Internal (InternalResult(..),indexLatinCharArray,upcastUnitSuccess) +import Data.Bytes.Parser.Internal (boxBytes) +import Data.Bytes.Parser (bindFromLiftedToInt) +import Data.Word (Word8) +import Data.Char (ord) +import Data.Kind (Type) +import GHC.Exts (Int(I#),Char(C#),Word#,Int#,Char#,(+#),(-#),indexCharArray#) +import GHC.Exts (TYPE,RuntimeRep) +import GHC.Word (Word(W#),Word8(W8#),Word16(W16#),Word32(W32#)) + +import qualified GHC.Exts as Exts +import qualified Data.Bytes as Bytes +import qualified Data.Primitive as PM + +-- | Runs the predicate on the next character in the input. If the +-- predicate is matched, this consumes the character. Otherwise, +-- the character is not consumed. This returns @False@ if the end +-- of the input has been reached. This never fails. +trySatisfy :: (Char -> Bool) -> Parser e s Bool +trySatisfy f = uneffectful $ \chunk -> case length chunk of + 0 -> InternalSuccess False (offset chunk) (length chunk) + _ -> case f (indexLatinCharArray (array chunk) (offset chunk)) of + True -> InternalSuccess True (offset chunk + 1) (length chunk - 1) + False -> InternalSuccess False (offset chunk) (length chunk) + +-- | Runs the function on the next character in the input. If the +-- function returns @Just@, this consumes the character and then +-- runs the parser on the remaining input. If the function returns +-- @Nothing@, this does not consume the tested character, and it +-- runs the default parser on the input (which includes the tested +-- character). If there is no input remaining, this also runs the +-- default parser. This combinator never fails. +trySatisfyThen :: forall (r :: RuntimeRep) (e :: Type) (s :: Type) (a :: TYPE r). + Parser e s a -- ^ Default parser. Runs on @Nothing@ or end of input. + -> (Char -> Maybe (Parser e s a)) -- ^ Parser-selecting predicate + -> Parser e s a +{-# inline trySatisfyThen #-} +trySatisfyThen (Parser g) f = Parser + (\input@(# arr,off0,len0 #) s0 -> case len0 of + 0# -> g input s0 + _ -> case f (C# (indexCharArray# arr off0)) of + Nothing -> g input s0 + Just (Parser p) -> p (# arr, off0 +# 1#, len0 -# 1# #) s0 + ) + +-- | Consume the next character, failing if it does not +-- match the expected value or if there is no more input. +char :: e -> Char -> Parser e s () +-- GHC should decide to inline this after optimization. +char e !c = uneffectful $ \chunk -> if length chunk > 0 + then if indexLatinCharArray (array chunk) (offset chunk) == c + then InternalSuccess () (offset chunk + 1) (length chunk - 1) + else InternalFailure e + else InternalFailure e + +-- | Consume the next two characters, failing if they do +-- not match they expected values. +-- +-- > char2 e a b === char e a *> char e b +char2 :: e -> Char -> Char -> Parser e s () +-- GHC should decide to inline this after optimization. +char2 e !c0 !c1 = uneffectful $ \chunk -> + if | length chunk > 1 + , indexLatinCharArray (array chunk) (offset chunk) == c0 + , indexLatinCharArray (array chunk) (offset chunk + 1) == c1 + -> InternalSuccess () (offset chunk + 2) (length chunk - 2) + | otherwise -> InternalFailure e + +-- | Consume the three characters, failing if they do +-- not match they expected values. +-- +-- > char3 e a b c === char e a *> char e b *> char e c +char3 :: e -> Char -> Char -> Char -> Parser e s () +-- GHC should decide to inline this after optimization. +char3 e !c0 !c1 !c2 = uneffectful $ \chunk -> + if | length chunk > 2 + , indexLatinCharArray (array chunk) (offset chunk) == c0 + , indexLatinCharArray (array chunk) (offset chunk + 1) == c1 + , indexLatinCharArray (array chunk) (offset chunk + 2) == c2 + -> InternalSuccess () (offset chunk + 3) (length chunk - 3) + | otherwise -> InternalFailure e + +-- | Consume the four characters, failing if they do +-- not match they expected values. +-- +-- > char4 e a b c d === char e a *> char e b *> char e c *> char e d +char4 :: e -> Char -> Char -> Char -> Char -> Parser e s () +-- GHC should decide to inline this after optimization. +char4 e !c0 !c1 !c2 !c3 = uneffectful $ \chunk -> + if | length chunk > 3 + , indexLatinCharArray (array chunk) (offset chunk) == c0 + , indexLatinCharArray (array chunk) (offset chunk + 1) == c1 + , indexLatinCharArray (array chunk) (offset chunk + 2) == c2 + , indexLatinCharArray (array chunk) (offset chunk + 3) == c3 + -> InternalSuccess () (offset chunk + 4) (length chunk - 4) + | otherwise -> InternalFailure e + +-- | Consumes and returns the next character in the input. +any :: e -> Parser e s Char +any e = uneffectful $ \chunk -> if length chunk > 0 + then + let c = indexLatinCharArray (array chunk) (offset chunk) + in InternalSuccess c (offset chunk + 1) (length chunk - 1) + else InternalFailure e + +-- | Consume a character from the input or return Nothing if +-- end of the stream has been reached. Since ISO 8859-1 maps every +-- bytes to a character, this parser never fails. +opt :: Parser e s (Maybe Char) +opt = uneffectful $ \chunk -> case length chunk of + 0 -> InternalSuccess Nothing (offset chunk) (length chunk) + _ -> InternalSuccess + (Just (indexLatinCharArray (array chunk) (offset chunk))) + (offset chunk + 1) (length chunk - 1) + +-- | Variant of @opt@ with unboxed result. +opt# :: Parser e s (# (# #) | Char# #) +{-# inline opt# #-} +opt# = Parser + (\(# arr, off, len #) s0 -> case len of + 0# -> (# s0, (# | (# (# (# #) | #), off, len #) #) #) + _ -> (# s0, (# | (# (# | indexCharArray# arr off #), off +# 1#, len -# 1# #) #) #) + ) + +skipDigitsAsciiLoop :: + Bytes -- Chunk + -> (# Int#, Int# #) +skipDigitsAsciiLoop !c = if length c > 0 + then + let w = indexLatinCharArray (array c) (offset c) + in if w >= '0' && w <= '9' + then skipDigitsAsciiLoop (Bytes.unsafeDrop 1 c) + else (# unI (offset c), unI (length c) #) + else (# unI (offset c), unI (length c) #) + +skipDigitsAscii1LoopStart :: + e + -> Bytes -- chunk + -> Result# e () +skipDigitsAscii1LoopStart e !c = if length c > 0 + then + let w = indexLatinCharArray (array c) (offset c) + in if w >= '0' && w <= '9' + then upcastUnitSuccess (skipDigitsAsciiLoop (Bytes.unsafeDrop 1 c)) + else (# e | #) + else (# e | #) + +-- | Variant of 'skipDigits' that requires at least one digit +-- to be present. +skipDigits1 :: e -> Parser e s () +skipDigits1 e = uneffectful# $ \c -> + skipDigitsAscii1LoopStart e c + +-- | Skip the characters @0-9@ until a non-digit is encountered. +-- This parser does not fail. +skipDigits :: Parser e s () +skipDigits = uneffectful# $ \c -> + upcastUnitSuccess (skipDigitsAsciiLoop c) + +unI :: Int -> Int# +unI (I# w) = w + +-- | Skip the character any number of times. This succeeds +-- even if the character was not present. +skipChar :: Char -> Parser e s () +skipChar !w = uneffectful# $ \c -> + upcastUnitSuccess (skipLoop w c) + +-- | Skip the character any number of times. It must occur +-- at least once or else this will fail. +skipChar1 :: e -> Char -> Parser e s () +skipChar1 e !w = uneffectful# $ \c -> + skipLoop1Start e w c + +skipLoop :: + Char -- byte to match + -> Bytes -- Chunk + -> (# Int#, Int# #) +skipLoop !w !c = if length c > 0 + then if indexLatinCharArray (array c) (offset c) == w + then skipLoop w (Bytes.unsafeDrop 1 c) + else (# unI (offset c), unI (length c) #) + else (# unI (offset c), unI (length c) #) + +skipLoop1Start :: + e + -> Char -- byte to match + -> Bytes -- chunk + -> Result# e () +skipLoop1Start e !w !chunk0 = if length chunk0 > 0 + then if indexLatinCharArray (array chunk0) (offset chunk0) == w + then upcastUnitSuccess (skipLoop w (Bytes.unsafeDrop 1 chunk0)) + else (# e | #) + else (# e | #) + +-- | Parse a decimal-encoded 8-bit word. If the number is larger +-- than 255, this parser fails. +decWord8 :: e -> Parser e s Word8 +decWord8 e = Parser + (\chunk0 s0 -> case decSmallWordStart e 256 (boxBytes chunk0) s0 of + (# s1, r #) -> (# s1, upcastWord8Result r #) + ) + +-- | Parse a decimal-encoded 16-bit word. If the number is larger +-- than 65535, this parser fails. +decWord16 :: e -> Parser e s Word16 +decWord16 e = Parser + (\chunk0 s0 -> case decSmallWordStart e 65536 (boxBytes chunk0) s0 of + (# s1, r #) -> (# s1, upcastWord16Result r #) + ) + +-- | Parse a decimal-encoded 32-bit word. If the number is larger +-- than 4294967295, this parser fails. +decWord32 :: e -> Parser e s Word32 +-- This will not work on 32-bit platforms. +decWord32 e = Parser + (\chunk0 s0 -> case decSmallWordStart e 4294967296 (boxBytes chunk0) s0 of + (# s1, r #) -> (# s1, upcastWord32Result r #) + ) + +-- | Parse a decimal-encoded number. If the number is too large to be +-- represented by a machine word, this fails with the provided +-- error message. This accepts any number of leading zeroes. +decWord :: e -> Parser e s Word +decWord e = Parser + (\chunk0 s0 -> case decWordStart e (boxBytes chunk0) s0 of + (# s1, r #) -> (# s1, upcastWordResult r #) + ) + +decSmallWordStart :: + e -- Error message + -> Word -- Upper Bound + -> Bytes -- Chunk + -> ST# s (Result# e Word# ) +decSmallWordStart e !limit !chunk0 s0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then (# s0, decSmallWordMore e w limit (Bytes.unsafeDrop 1 chunk0) #) + else (# s0, (# e | #) #) + else (# s0, (# e | #) #) + +-- This will not inline since it is recursive, but worker +-- wrapper will still happen. +decWordMore :: + e -- Error message + -> Word -- Accumulator + -> Bytes -- Chunk + -> Result# e Word# +decWordMore e !acc !chunk0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + !acc' = acc * 10 + w + in if w < 10 && acc' >= acc + then decWordMore e acc' (Bytes.unsafeDrop 1 chunk0) + else (# | (# unW acc, unI (offset chunk0), unI (length chunk0) #) #) + else (# | (# unW acc, unI (offset chunk0), 0# #) #) + + +upcastWordResult :: Result# e Word# -> Result# e Word +upcastWordResult (# e | #) = (# e | #) +upcastWordResult (# | (# a, b, c #) #) = (# | (# W# a, b, c #) #) + +decSmallWordMore :: + e -- Error message + -> Word -- Accumulator + -> Word -- Upper Bound + -> Bytes -- Chunk + -> Result# e Word# +decSmallWordMore e !acc !limit !chunk0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then + let w' = acc * 10 + w + in if w' < limit + then decSmallWordMore e w' limit (Bytes.unsafeDrop 1 chunk0) + else (# e | #) + else (# | (# unW acc, unI (offset chunk0), unI (length chunk0) #) #) + else (# | (# unW acc, unI (offset chunk0), 0# #) #) + +unW :: Word -> Word# +unW (W# w) = w + +decWordStart :: + e -- Error message + -> Bytes -- Chunk + -> ST# s (Result# e Word# ) +decWordStart e !chunk0 s0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then (# s0, decWordMore e w (Bytes.unsafeDrop 1 chunk0) #) + else (# s0, (# e | #) #) + else (# s0, (# e | #) #) + +-- Precondition: the word is small enough +upcastWord16Result :: Result# e Word# -> Result# e Word16 +upcastWord16Result (# e | #) = (# e | #) +upcastWord16Result (# | (# a, b, c #) #) = (# | (# W16# a, b, c #) #) + +-- Precondition: the word is small enough +upcastWord32Result :: Result# e Word# -> Result# e Word32 +upcastWord32Result (# e | #) = (# e | #) +upcastWord32Result (# | (# a, b, c #) #) = (# | (# W32# a, b, c #) #) + +-- Precondition: the word is small enough +upcastWord8Result :: Result# e Word# -> Result# e Word8 +upcastWord8Result (# e | #) = (# e | #) +upcastWord8Result (# | (# a, b, c #) #) = (# | (# W8# a, b, c #) #) + +-- | Parse a decimal-encoded number. If the number is too large to be +-- represented by a machine integer, this fails with the provided +-- error message. This rejects input with that is preceeded by plus +-- or minus. Consequently, it does not parse negative numbers. Use +-- 'decStandardInt' or 'decSignedInt' for that purpose. On a 64-bit +-- platform 'decWord' will successfully parse 9223372036854775808 +-- (i.e. @2 ^ 63@), but 'decUnsignedInt' will fail. This parser allows +-- leading zeroes. +decUnsignedInt :: e -> Parser e s Int +decUnsignedInt e = Parser + (\chunk0 s0 -> case decPosIntStart e (boxBytes chunk0) s0 of + (# s1, r #) -> (# s1, upcastIntResult r #) + ) + +-- | Variant of 'decUnsignedInt' with an unboxed result. +decUnsignedInt# :: e -> Parser e s Int# +decUnsignedInt# e = Parser + (\chunk0 s0 -> decPosIntStart e (boxBytes chunk0) s0) + +-- | Parse a decimal-encoded number. If the number is too large to be +-- represented by a machine integer, this fails with the provided +-- error message. This allows the number to optionally be prefixed +-- by plus or minus. If the sign prefix is not present, the number +-- is interpreted as positive. This allows leading zeroes. +decSignedInt :: e -> Parser e s Int +decSignedInt e = Parser + (\chunk0 s0 -> case runParser (decSignedInt# e) chunk0 s0 of + (# s1, r #) -> (# s1, upcastIntResult r #) + ) + +-- | Variant of 'decUnsignedInt' that lets the caller supply a leading +-- digit. This is useful when parsing formats like JSON where integers with +-- leading zeroes are considered invalid. The calling context must +-- consume the first digit before calling this parser. Results are +-- always positive numbers. +decTrailingInt :: + e -- ^ Error message + -> Int -- ^ Leading digit, should be between @0@ and @9@. + -> Parser e s Int +decTrailingInt e (I# w) = Parser + (\chunk0 s0 -> case runParser (decTrailingInt# e w) chunk0 s0 of + (# s1, r #) -> (# s1, upcastIntResult r #) + ) + +decTrailingInt# :: + e -- Error message + -> Int# -- Leading digit, should be between @0@ and @9@. + -> Parser e s Int# +decTrailingInt# e !w = + Parser (\chunk0 s0 -> (# s0, decPosIntMore e (I# w) (boxBytes chunk0) #)) + +-- | Parse a decimal-encoded number. If the number is too large to be +-- represented by a machine integer, this fails with the provided +-- error message. This allows the number to optionally be prefixed +-- by minus. If the minus prefix is not present, the number +-- is interpreted as positive. The disallows a leading plus sign. +-- For example, 'decStandardInt' rejects @+42@, but 'decSignedInt' +-- allows it. +decStandardInt :: e -> Parser e s Int +decStandardInt e = Parser + (\chunk0 s0 -> case runParser (decStandardInt# e) chunk0 s0 of + (# s1, r #) -> (# s1, upcastIntResult r #) + ) + +decSignedInt# :: e -> Parser e s Int# +{-# noinline decSignedInt# #-} +decSignedInt# e = any e `bindFromLiftedToInt` \c -> case c of + '+' -> Parser -- plus sign + (\chunk0 s0 -> decPosIntStart e (boxBytes chunk0) s0) + '-' -> Parser -- minus sign + (\chunk0 s0 -> decNegIntStart e (boxBytes chunk0) s0) + _ -> Parser -- no sign, there should be a digit here + (\chunk0 s0 -> + let !w = char2Word c - 48 + in if w < 10 + then (# s0, decPosIntMore e (fromIntegral @Word @Int w) (boxBytes chunk0) #) + else (# s0, (# e | #) #) + ) + +-- This is the same as decSignedInt except that we disallow +-- a leading plus sign. +decStandardInt# :: e -> Parser e s Int# +{-# noinline decStandardInt# #-} +decStandardInt# e = any e `bindFromLiftedToInt` \c -> case c of + '-' -> Parser -- minus sign + (\chunk0 s0 -> decNegIntStart e (boxBytes chunk0) s0) + _ -> Parser -- no sign, there should be a digit here + (\chunk0 s0 -> + let !w = char2Word c - 48 + in if w < 10 + then (# s0, decPosIntMore e (fromIntegral @Word @Int w) (boxBytes chunk0) #) + else (# s0, (# e | #) #) + ) + +-- | Variant of 'decUnsignedInteger' that lets the caller supply a leading +-- digit. This is useful when parsing formats like JSON where integers with +-- leading zeroes are considered invalid. The calling context must +-- consume the first digit before calling this parser. Results are +-- always positive numbers. +decTrailingInteger :: + Int -- ^ Leading digit, should be between @0@ and @9@. + -> Parser e s Integer +decTrailingInteger (I# w) = + Parser (\chunk0 s0 -> (# s0, (# | decIntegerChunks (I# w) 10 0 (boxBytes chunk0) #) #)) + +-- | Parse a decimal-encoded positive integer of arbitrary +-- size. This rejects input that begins with a plus or minus +-- sign. +decUnsignedInteger :: e -> Parser e s Integer +decUnsignedInteger e = Parser + (\chunk0 s0 -> decUnsignedIntegerStart e (boxBytes chunk0) s0) + +-- | Parse a decimal-encoded integer of arbitrary size. +-- This accepts input that begins with a plus or minus sign. +-- Input without a sign prefix is interpreted as positive. +decSignedInteger :: e -> Parser e s Integer +{-# noinline decSignedInteger #-} +decSignedInteger e = any e >>= \c -> case c of + '+' -> do + decUnsignedInteger e + '-' -> do + x <- decUnsignedInteger e + pure $! negate x + _ -> Parser -- no sign, there should be a digit here + (\chunk0 s0 -> + let !w = char2Word c - 48 in + if w < 10 + then + let !r = decIntegerChunks + (fromIntegral @Word @Int w) + 10 + 0 + (boxBytes chunk0) + in (# s0, (# | r #) #) + else (# s0, (# e | #) #) + ) + +decPosIntStart :: + e -- Error message + -> Bytes -- Chunk + -> ST# s (Result# e Int# ) +decPosIntStart e !chunk0 s0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then (# s0, decPosIntMore e (fromIntegral @Word @Int w) (Bytes.unsafeDrop 1 chunk0) #) + else (# s0, (# e | #) #) + else (# s0, (# e | #) #) + +decNegIntStart :: + e -- Error message + -> Bytes -- Chunk + -> ST# s (Result# e Int# ) +decNegIntStart e !chunk0 s0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then (# s0, decNegIntMore e (negate (fromIntegral @Word @Int w)) (Bytes.unsafeDrop 1 chunk0) #) + else (# s0, (# e | #) #) + else (# s0, (# e | #) #) + +decUnsignedIntegerStart :: + e + -> Bytes + -> ST# s (Result# e Integer) +decUnsignedIntegerStart e !chunk0 s0 = if length chunk0 > 0 + then + let !w = (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < (10 :: Word8) + then + let !r = decIntegerChunks + (fromIntegral @Word8 @Int w) + 10 + 0 + (Bytes.unsafeDrop 1 chunk0) + in (# s0, (# | r #) #) + else (# s0, (# e | #) #) + else (# s0, (# e | #) #) + +-- This will not inline since it is recursive, but worker +-- wrapper will still happen. +decNegIntMore :: + e -- Error message + -> Int -- Accumulator + -> Bytes -- Chunk + -> Result# e Int# +decNegIntMore e !acc !chunk0 = if length chunk0 > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + !acc' = acc * 10 - (fromIntegral @Word @Int w) + in if w < 10 + then if acc' <= acc + then decNegIntMore e acc' (Bytes.unsafeDrop 1 chunk0) + else (# e | #) + else (# | (# unI acc, unI (offset chunk0), unI (length chunk0) #) #) + else (# | (# unI acc, unI (offset chunk0), 0# #) #) + +-- This will not inline since it is recursive, but worker +-- wrapper will still happen. Fails if the accumulator +-- exceeds the size of a machine integer. +decPosIntMore :: + e -- Error message + -> Int -- Accumulator + -> Bytes -- Chunk + -> Result# e Int# +decPosIntMore e !acc !chunk0 = if len > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + !acc' = acc * 10 + (fromIntegral @Word @Int w) + in if w < 10 + then if acc' >= acc + then decPosIntMore e acc' (Bytes.unsafeDrop 1 chunk0) + else (# e | #) + else (# | (# unI acc, unI (offset chunk0), len# #) #) + else (# | (# unI acc, unI (offset chunk0), 0# #) #) + where + !len@(I# len# ) = length chunk0 + +-- This will not inline since it is recursive, but worker +-- wrapper will still happen. When the accumulator +-- exceeds the size of a machine integer, this pushes the +-- accumulated machine int and the shift amount onto the +-- stack. +-- We are intentionally lazy in the accumulator. There is +-- no need to force this on every iteration. We do however, +-- force it preemptively every time it changes. +-- Because of how we track overflow, we are able to use the +-- same function for both positive and negative numbers. +decIntegerChunks :: + Int -- Chunk accumulator (e.g. 236) + -> Int -- Chunk base-ten bound (e.g. 1000) + -> Integer -- Accumulator + -> Bytes -- Chunk + -> (# Integer, Int#, Int# #) +decIntegerChunks !nAcc !eAcc acc !chunk0 = if len > 0 + then + let !w = fromIntegral @Word8 @Word + (PM.indexByteArray (array chunk0) (offset chunk0)) - 48 + in if w < 10 + then let !eAcc' = eAcc * 10 in + if eAcc' >= eAcc + then decIntegerChunks + (nAcc * 10 + fromIntegral @Word @Int w) + eAcc' + acc + (Bytes.unsafeDrop 1 chunk0) + else + -- In this case, notice that we deliberately + -- unconsume the digit that would have caused + -- an overflow. + let !r = (acc * fromIntegral @Int @Integer eAcc) + + (fromIntegral @Int @Integer nAcc) + in decIntegerChunks 0 1 r chunk0 + else + let !r = (acc * fromIntegral @Int @Integer eAcc) + + (fromIntegral @Int @Integer nAcc) + in (# r, unI (offset chunk0), len# #) + else + let !r = (acc * fromIntegral @Int @Integer eAcc) + + (fromIntegral @Int @Integer nAcc) + in (# r, unI (offset chunk0), 0# #) + where + !len@(I# len# ) = length chunk0 + +upcastIntResult :: Result# e Int# -> Result# e Int +upcastIntResult (# e | #) = (# e | #) +upcastIntResult (# | (# a, b, c #) #) = (# | (# I# a, b, c #) #) + +char2Word :: Char -> Word +char2Word = fromIntegral . ord + +-- | Skip all characters until the character from the is encountered +-- and then consume the matching character as well. Visually, +-- @skipTrailedBy \'C\'@ advances the cursor like this: +-- +-- > A Z B Y C X C W +-- > |->->->->-| +skipTrailedBy :: e -> Char -> Parser e s () +skipTrailedBy e !w = uneffectful# $ \c -> + skipUntilConsumeLoop e w c + +skipUntilConsumeLoop :: + e -- Error message + -> Char -- byte to match + -> Bytes -- Chunk + -> Result# e () +skipUntilConsumeLoop e !w !c = if length c > 0 + then if indexLatinCharArray (array c) (offset c) /= w + then skipUntilConsumeLoop e w (Bytes.unsafeDrop 1 c) + else (# | (# (), unI (offset c + 1), unI (length c - 1) #) #) + else (# e | #) + +-- | Parse exactly four ASCII-encoded characters, interpretting +-- them as the hexadecimal encoding of a 32-bit number. Note that +-- this rejects a sequence such as @5A9@, requiring @05A9@ instead. +-- This is insensitive to case. This is particularly useful when +-- parsing escape sequences in C or JSON, which allow encoding +-- characters in the Basic Multilingual Plane as @\\uhhhh@. +hexWord16 :: e -> Parser e s Word16 +{-# inline hexWord16 #-} +hexWord16 e = Parser + (\x s0 -> case runParser (hexWord16# e) x s0 of + (# s1, r #) -> case r of + (# err | #) -> (# s1, (# err | #) #) + (# | (# a, b, c #) #) -> (# s1, (# | (# W16# a, b, c #) #) #) + ) + +hexWord16# :: e -> Parser e s Word# +{-# noinline hexWord16# #-} +hexWord16# e = uneffectfulWord# $ \chunk -> if length chunk >= 4 + then + let !w0@(W# n0) = oneHex $ PM.indexByteArray (array chunk) (offset chunk) + !w1@(W# n1) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 1) + !w2@(W# n2) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 2) + !w3@(W# n3) = oneHex $ PM.indexByteArray (array chunk) (offset chunk + 3) + in if | w0 .|. w1 .|. w2 .|. w3 /= maxBound -> + (# | + (# (n0 `Exts.timesWord#` 4096##) `Exts.plusWord#` + (n1 `Exts.timesWord#` 256##) `Exts.plusWord#` + (n2 `Exts.timesWord#` 16##) `Exts.plusWord#` + n3 + , unI (offset chunk) +# 4# + , unI (length chunk) -# 4# #) #) + | otherwise -> (# e | #) + else (# e | #) + + +-- Returns the maximum machine word if the argument is not +-- the ASCII encoding of a hexadecimal digit. +oneHex :: Word8 -> Word +oneHex w + | w >= 48 && w < 58 = (fromIntegral w - 48) + | w >= 65 && w < 71 = (fromIntegral w - 55) + | w >= 97 && w < 103 = (fromIntegral w - 87) + | otherwise = maxBound + +uneffectfulWord# :: (Bytes -> Result# e Word#) -> Parser e s Word# +uneffectfulWord# f = Parser + ( \b s0 -> (# s0, (f (boxBytes b)) #) ) + diff --git a/src/Data/Bytes/Parser/Unsafe.hs b/src/Data/Bytes/Parser/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/Unsafe.hs @@ -0,0 +1,62 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +-- | Everything in this module is unsafe and can lead to +-- nondeterministic output or segfaults if used incorrectly. +module Data.Bytes.Parser.Unsafe + ( cursor + , expose + , unconsume + , jump + ) where + +import Prelude hiding (length) + +import Data.Primitive (ByteArray) +import Data.Bytes.Types (Bytes(..)) +import Data.Bytes.Parser.Internal (Parser(..),uneffectful) +import Data.Bytes.Parser.Internal (InternalResult(..)) + +-- | Get the current offset into the chunk. Using this makes +-- it possible to observe the internal difference between 'Bytes' +-- that refer to equivalent slices. Be careful. +cursor :: Parser e s Int +cursor = uneffectful $ \chunk -> + InternalSuccess (offset chunk) (offset chunk) (length chunk) + +-- | Return the byte array being parsed. This includes bytes +-- that preceed the current offset and may include bytes that +-- go beyond the length. This is somewhat dangerous, so only +-- use this is you know what you're doing. +expose :: Parser e s ByteArray +expose = uneffectful $ \chunk -> + InternalSuccess (array chunk) (offset chunk) (length chunk) + +-- | Move the cursor back by @n@ bytes. Precondition: you +-- must have previously consumed at least @n@ bytes. +unconsume :: Int -> Parser e s () +unconsume n = uneffectful $ \chunk -> + InternalSuccess () (offset chunk - n) (length chunk + n) + +-- | Set the position to the given index. Precondition: the index +-- must be valid. It should be the result of an earlier call to +-- 'cursor'. +jump :: Int -> Parser e s () +jump ix = uneffectful $ \chunk -> + InternalSuccess () ix (length chunk + (offset chunk - ix)) + diff --git a/src/Data/Bytes/Parser/Utf8.hs b/src/Data/Bytes/Parser/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bytes/Parser/Utf8.hs @@ -0,0 +1,143 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language DerivingStrategies #-} +{-# language GADTSyntax #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language MultiWayIf #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedSums #-} +{-# language UnboxedTuples #-} + +-- | Parse input as UTF-8-encoded text. Parsers in this module will +-- fail if they encounter a byte above @0x7F@. +module Data.Bytes.Parser.Utf8 + ( -- * Get Character + any# + , shortText + ) where + +import Prelude hiding (length,any,fail,takeWhile) + +import Data.Bits ((.&.),(.|.),unsafeShiftL,xor) +import Data.Bytes.Parser.Internal (Parser(..)) +import Data.Text.Short (ShortText) +import GHC.Exts (Int(I#),Char(C#),Int#,Char#,(-#),(+#),(>#),chr#) +import GHC.Word (Word8(W8#)) + +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.Bytes.Parser as Parser +import qualified Data.Primitive as PM +import qualified Data.Text.Short as TS +import qualified GHC.Exts as Exts + +-- | Interpret the next one to four bytes as a UTF-8-encoded character. +-- Fails if the decoded codepoint is in the range U+D800 through U+DFFF. +any# :: e -> Parser e s Char# +{-# noinline any# #-} +any# e = Parser + (\(# arr, off, len #) s0 -> case len ># 0# of + 1# -> + let !w0 = Exts.indexWord8Array# arr off + in if | oneByteChar (W8# w0) -> + (# s0, (# | (# chr# (Exts.word2Int# w0), off +# 1#, len -# 1# #) #) #) + | twoByteChar (W8# w0) -> + if | I# len > 1 + , w1 <- Exts.indexWord8Array# arr (off +# 1#) + , followingByte (W8# w1) + , C# c <- codepointFromTwoBytes (W8# w0) (W8# w1) + -> (# s0, (# | (# c, off +# 2#, len -# 2# #) #) #) + | otherwise -> (# s0, (# e | #) #) + | threeByteChar (W8# w0) -> + if | I# len > 2 + , w1 <- Exts.indexWord8Array# arr (off +# 1# ) + , w2 <- Exts.indexWord8Array# arr (off +# 2# ) + , followingByte (W8# w1) + , !c@(C# c#) <- codepointFromThreeBytes (W8# w0) (W8# w1) (W8# w2) + , c < '\xD800' || c > '\xDFFF' + -> (# s0, (# | (# c#, off +# 3#, len -# 3# #) #) #) + | otherwise -> (# s0, (# e | #) #) + | fourByteChar (W8# w0) -> + if | I# len > 3 + , w1 <- Exts.indexWord8Array# arr (off +# 1# ) + , w2 <- Exts.indexWord8Array# arr (off +# 2# ) + , w3 <- Exts.indexWord8Array# arr (off +# 3# ) + , followingByte (W8# w1) + , !(C# c#) <- codepointFromFourBytes (W8# w0) (W8# w1) (W8# w2) (W8# w3) + -> (# s0, (# | (# c#, off +# 4#, len -# 4# #) #) #) + | otherwise -> (# s0, (# e | #) #) + | otherwise -> (# s0, (# e | #) #) + _ -> (# s0, (# e | #) #) + ) + +codepointFromFourBytes :: Word8 -> Word8 -> Word8 -> Word8 -> Char +codepointFromFourBytes w1 w2 w3 w4 = C# + ( chr# + ( unI $ fromIntegral + ( unsafeShiftL (word8ToWord w1 .&. 0b00001111) 18 .|. + unsafeShiftL (word8ToWord w2 .&. 0b00111111) 12 .|. + unsafeShiftL (word8ToWord w3 .&. 0b00111111) 6 .|. + (word8ToWord w4 .&. 0b00111111) + ) + ) + ) + +codepointFromThreeBytes :: Word8 -> Word8 -> Word8 -> Char +codepointFromThreeBytes w1 w2 w3 = C# + ( chr# + ( unI $ fromIntegral + ( unsafeShiftL (word8ToWord w1 .&. 0b00001111) 12 .|. + unsafeShiftL (word8ToWord w2 .&. 0b00111111) 6 .|. + (word8ToWord w3 .&. 0b00111111) + ) + ) + ) + +codepointFromTwoBytes :: Word8 -> Word8 -> Char +codepointFromTwoBytes w1 w2 = C# + ( chr# + ( unI $ fromIntegral @Word @Int + ( unsafeShiftL (word8ToWord w1 .&. 0b00011111) 6 .|. + (word8ToWord w2 .&. 0b00111111) + ) + ) + ) + +oneByteChar :: Word8 -> Bool +oneByteChar !w = w .&. 0b10000000 == 0 + +twoByteChar :: Word8 -> Bool +twoByteChar !w = w .&. 0b11100000 == 0b11000000 + +threeByteChar :: Word8 -> Bool +threeByteChar !w = w .&. 0b11110000 == 0b11100000 + +fourByteChar :: Word8 -> Bool +fourByteChar !w = w .&. 0b11111000 == 0b11110000 + +followingByte :: Word8 -> Bool +followingByte !w = xor w 0b01000000 .&. 0b11000000 == 0b11000000 + +word8ToWord :: Word8 -> Word +word8ToWord = fromIntegral + +unI :: Int -> Int# +unI (I# w) = w + +-- | Consume input that matches the argument. Fails if the +-- input does not match. +shortText :: e -> ShortText -> Parser e s () +shortText e !t = Parser.byteArray e + (shortByteStringToByteArray (TS.toShortByteString t)) + +shortByteStringToByteArray :: + BSS.ShortByteString + -> PM.ByteArray +shortByteStringToByteArray (BSS.SBS x) = PM.ByteArray x diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,43 +1,167 @@ {-# language BangPatterns #-} {-# language MultiWayIf #-} +{-# language NumDecimals #-} +{-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} -import Control.Exception (throwIO) -import Data.Primitive (ByteArray) -import Data.Word (Word8) +import Control.Monad (replicateM) +import Control.Monad.ST (runST) +import Data.Primitive (ByteArray,PrimArray) +import Data.Word (Word8,Word64) import Data.Char (ord) import Data.Bytes.Types (Bytes(Bytes)) -import Data.Bytes.Parser (Parser,Result(..)) +import Test.Tasty (defaultMain,testGroup,TestTree) +import Test.Tasty.HUnit ((@=?),testCase) +import Test.Tasty.QuickCheck ((===),testProperty) +import qualified Data.Bits as Bits import qualified Data.Bytes.Parser as P +import qualified Data.Bytes.Parser.Ascii as Ascii +import qualified Data.Bytes.Parser.Latin as Latin +import qualified Data.Bytes.Parser.BigEndian as BigEndian import qualified Data.Primitive as PM import qualified GHC.Exts as Exts +import qualified Test.Tasty.QuickCheck as QC main :: IO () -main = do - putStrLn "Start" - putStrLn "A" - testA - putStrLn "Finished" +main = defaultMain tests -testA :: IO () -testA = - let r = P.parseByteArray +tests :: TestTree +tests = testGroup "Parser" + [ testProperty "decStandardInt" $ \i -> + P.parseBytes (Latin.decStandardInt ()) (bytes (show i)) === P.Success i 0 + , testProperty "big-endian-word64" bigEndianWord64 + , testCase "delimit" $ + P.Success (167,14625) 0 + @=? + P.parseBytes + (do len <- Latin.decUnsignedInt () + Latin.char () ',' + r <- P.delimit () () len $ (,) + <$> Latin.decUnsignedInt () + <* Latin.char () '*' + <*> Latin.decUnsignedInt () + Latin.char () '0' + pure r + ) (bytes "9,167*146250") + , testGroup "decUnsignedInt" + [ testCase "A" $ + P.Failure () + @=? + P.parseBytes (Latin.decUnsignedInt ()) + (bytes "742493495120739103935542") + , testCase "B" $ + P.Success 4654667 3 + @=? + P.parseBytes (Latin.decUnsignedInt ()) + (bytes "4654667,55") + , testProperty "property" $ \(QC.NonNegative i) -> + P.parseBytes (Latin.decUnsignedInt ()) (bytes (show i)) + === + P.Success i 0 + ] + , testGroup "decPositiveInteger" + [ testCase "A" $ + P.parseBytes (Latin.decUnsignedInteger ()) + (bytes "5469999463123462573426452736423546373235260") + @=? + P.Success 5469999463123462573426452736423546373235260 0 + , testProperty "property" $ \(LargeInteger i) -> + i >= 0 + QC.==> + P.parseBytes (Latin.decUnsignedInteger ()) (bytes (show i)) + === + P.Success i 0 + ] + , testGroup "decSignedInteger" + [ testCase "A" $ + P.parseBytes (Latin.decSignedInteger ()) + (bytes "-54699994631234625734264527364235463732352601") + @=? + P.Success (-54699994631234625734264527364235463732352601) 0 + , testProperty "property" $ \(LargeInteger i) -> + P.parseBytes (Latin.decSignedInteger ()) (bytes (show i)) + === + P.Success i 0 + ] + , testProperty "decSignedInt-A" $ \i -> + P.parseBytes (Latin.decSignedInt ()) (bytes (show i)) === P.Success i 0 + , testProperty "decSignedInt-B" $ \i -> + P.parseBytes + (Latin.decSignedInt ()) + (bytes ((if i >= 0 then "+" else "") ++ show i)) + === + P.Success i 0 + , testCase "decWord-composition" $ + P.Success (42,8) 0 + @=? + P.parseBytes ( pure (,) - <*> P.decWord () - <* P.ascii () '.' - <*> P.decWord () - <* P.ascii () '.' - ) (pack "42.8.") - in case r of - Failure () -> fail "test A failed parsing" - Success (42,8) 5 0 -> pure () - Success _ _ _ -> fail "test A wrong result" + <*> Ascii.decWord () + <* Ascii.char () '.' + <*> Ascii.decWord () + <* Ascii.char () '.' + ) (bytes "42.8.") + , testCase "decWord-replicate" $ + P.Success (Exts.fromList [42,93] :: PrimArray Word) 0 + @=? + P.parseBytes + (P.replicate 2 (Ascii.decWord () <* Ascii.char () '.')) + (bytes "42.93.") + ] bytes :: String -> Bytes -bytes s = let b = pack s in Bytes b 0 (PM.sizeofByteArray b) +bytes s = let b = pack ('x' : s) in Bytes b 1 (PM.sizeofByteArray b - 1) pack :: String -> ByteArray pack = Exts.fromList . map (fromIntegral @Int @Word8 . ord) + +bigEndianWord64 :: + Word8 -> Word8 -> Word8 -> Word8 + -> Word8 -> Word8 -> Word8 -> Word8 + -> QC.Property +bigEndianWord64 a b c d e f g h = + let arr = runST $ do + m <- PM.newByteArray 11 + PM.writeByteArray m 0 (0xFF :: Word8) + PM.writeByteArray m 1 (0xFF :: Word8) + PM.writeByteArray m 2 (a :: Word8) + PM.writeByteArray m 3 (b :: Word8) + PM.writeByteArray m 4 (c :: Word8) + PM.writeByteArray m 5 (d :: Word8) + PM.writeByteArray m 6 (e :: Word8) + PM.writeByteArray m 7 (f :: Word8) + PM.writeByteArray m 8 (g :: Word8) + PM.writeByteArray m 9 (h :: Word8) + PM.writeByteArray m 10 (0xEE :: Word8) + PM.unsafeFreezeByteArray m + expected = (0 :: Word64) + + fromIntegral a * 256 ^ (7 :: Integer) + + fromIntegral b * 256 ^ (6 :: Integer) + + fromIntegral c * 256 ^ (5 :: Integer) + + fromIntegral d * 256 ^ (4 :: Integer) + + fromIntegral e * 256 ^ (3 :: Integer) + + fromIntegral f * 256 ^ (2 :: Integer) + + fromIntegral g * 256 ^ (1 :: Integer) + + fromIntegral h * 256 ^ (0 :: Integer) + in P.parseBytes (BigEndian.word64 ()) (Bytes arr 2 9) + === + P.Success expected 1 + +-- The Arbitrary instance for Integer that comes with +-- QuickCheck only generates small numbers. +newtype LargeInteger = LargeInteger Integer + deriving (Eq,Show) + +instance QC.Arbitrary LargeInteger where + arbitrary = QC.sized $ \sz -> do + n <- QC.choose (1, sz) + sign <- QC.arbitrary + r <- (if sign then negate else id) . foldr f 0 + <$> replicateM n QC.arbitrary + pure (LargeInteger r) + where + f :: Word8 -> Integer -> Integer + f w acc = (acc `Bits.shiftL` 8) + fromIntegral w