diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,17 @@ +import qualified Data.Serialize as Cereal +import Data.String.ToString +import Gauge.Main +import qualified Ptr.Read as Read +import Prelude + +main = + defaultMain + [ bench "int32InBe" $ + nf + (Read.runOnByteStringFinishing (Read.int32InBe)) + $! Cereal.runPut (Cereal.putInt32be 1), + bench "int32InBe*3" $ + nf + (Read.runOnByteStringFinishing ((,,) <$> Read.int32InBe <*> Read.int32InBe <*> Read.int32InBe)) + $! Cereal.runPut (Cereal.putInt32be 1 <> Cereal.putInt32be 2 <> Cereal.putInt32be 3) + ] diff --git a/library/Ptr/ByteString.hs b/library/Ptr/ByteString.hs --- a/library/Ptr/ByteString.hs +++ b/library/Ptr/ByteString.hs @@ -1,12 +1,10 @@ -module Ptr.ByteString -where +module Ptr.ByteString where -import Ptr.Prelude -import qualified Ptr.Poking as A +import qualified Data.ByteString.Internal as B import qualified Ptr.Parse as C import qualified Ptr.Peek as D -import qualified Data.ByteString.Internal as B - +import qualified Ptr.Poking as A +import Ptr.Prelude {-# INLINE poking #-} poking :: A.Poking -> B.ByteString @@ -16,16 +14,18 @@ {-# INLINE parse #-} parse :: B.ByteString -> C.Parse result -> (Int -> result) -> (Text -> result) -> result parse (B.PS fp offset length) (C.Parse parseIO) eoi error = - {-# SCC "parse" #-} + {-# SCC "parse" #-} unsafePerformIO $ - withForeignPtr fp $ \ptr -> - parseIO length (plusPtr ptr offset) (return . eoi) (return . error) (\result _ _ -> return result) + withForeignPtr fp $ \ptr -> + parseIO length (plusPtr ptr offset) (return . eoi) (return . error) (\result _ _ -> return result) {-# INLINE peek #-} peek :: B.ByteString -> D.Peek result -> Maybe result peek (B.PS fp offset length) (D.Peek amount io) = - {-# SCC "peek" #-} + {-# SCC "peek" #-} if amount <= length - then Just $ unsafePerformIO $ withForeignPtr fp $ \ptr -> - io (plusPtr ptr offset) + then Just $ + unsafePerformIO $ + withForeignPtr fp $ \ptr -> + io (plusPtr ptr offset) else Nothing diff --git a/library/Ptr/IO.hs b/library/Ptr/IO.hs --- a/library/Ptr/IO.hs +++ b/library/Ptr/IO.hs @@ -1,23 +1,20 @@ {-# LANGUAGE CPP #-} -module Ptr.IO -where -import Ptr.Prelude +module Ptr.IO where + import qualified Data.ByteString.Internal as A import qualified Data.ByteString.Short.Internal as B +import Ptr.Prelude import qualified Ptr.UncheckedShifting as D - {-# INLINE peekStorable #-} peekStorable :: Storable storable => Ptr Word8 -> IO storable peekStorable = - {-# SCC "peekStorable" #-} peek . castPtr {-# INLINE peekWord8 #-} peekWord8 :: Ptr Word8 -> IO Word8 peekWord8 = - {-# SCC "peekWord8" #-} peekStorable -- | Big-endian word of 2 bytes. @@ -25,11 +22,9 @@ peekBEWord16 :: Ptr Word8 -> IO Word16 #ifdef WORDS_BIGENDIAN peekBEWord16 = - {-# SCC "peekBEWord16" #-} peekStorable #else peekBEWord16 = - {-# SCC "peekBEWord16" #-} fmap byteSwap16 . peekStorable #endif @@ -38,11 +33,9 @@ peekLEWord16 :: Ptr Word8 -> IO Word16 #ifdef WORDS_BIGENDIAN peekLEWord16 = - {-# SCC "peekLEWord16" #-} fmap byteSwap16 . peekStorable #else peekLEWord16 = - {-# SCC "peekLEWord16" #-} peekStorable #endif @@ -51,11 +44,9 @@ peekBEWord32 :: Ptr Word8 -> IO Word32 #ifdef WORDS_BIGENDIAN peekBEWord32 = - {-# SCC "peekBEWord32" #-} peekStorable #else peekBEWord32 = - {-# SCC "peekBEWord32" #-} fmap byteSwap32 . peekStorable #endif @@ -64,11 +55,9 @@ peekLEWord32 :: Ptr Word8 -> IO Word32 #ifdef WORDS_BIGENDIAN peekLEWord32 = - {-# SCC "peekLEWord32" #-} fmap byteSwap32 . peekStorable #else peekLEWord32 = - {-# SCC "peekLEWord32" #-} peekStorable #endif @@ -77,11 +66,9 @@ peekBEWord64 :: Ptr Word8 -> IO Word64 #ifdef WORDS_BIGENDIAN peekBEWord64 = - {-# SCC "peekBEWord64" #-} peekStorable #else peekBEWord64 = - {-# SCC "peekBEWord64" #-} fmap byteSwap64 . peekStorable #endif @@ -90,18 +77,15 @@ peekLEWord64 :: Ptr Word8 -> IO Word64 #ifdef WORDS_BIGENDIAN peekLEWord64 = - {-# SCC "peekLEWord64" #-} fmap byteSwap64 . peekStorable #else peekLEWord64 = - {-# SCC "peekLEWord64" #-} peekStorable #endif {-# INLINE peekInt8 #-} peekInt8 :: Ptr Word8 -> IO Int8 peekInt8 = - {-# SCC "peekInt8" #-} peekStorable -- | Big-endian int of 2 bytes. @@ -109,11 +93,9 @@ peekBEInt16 :: Ptr Word8 -> IO Int16 #ifdef WORDS_BIGENDIAN peekBEInt16 = - {-# SCC "peekBEInt16" #-} peekStorable #else peekBEInt16 = - {-# SCC "peekBEInt16" #-} fmap (fromIntegral . byteSwap16) . peekStorable #endif @@ -122,11 +104,9 @@ peekLEInt16 :: Ptr Word8 -> IO Int16 #ifdef WORDS_BIGENDIAN peekLEInt16 = - {-# SCC "peekLEInt16" #-} fmap (fromIntegral . byteSwap16) . peekStorable #else peekLEInt16 = - {-# SCC "peekLEInt16" #-} peekStorable #endif @@ -135,11 +115,9 @@ peekBEInt32 :: Ptr Word8 -> IO Int32 #ifdef WORDS_BIGENDIAN peekBEInt32 = - {-# SCC "peekBEInt32" #-} peekStorable #else peekBEInt32 = - {-# SCC "peekBEInt32" #-} fmap (fromIntegral . byteSwap32) . peekStorable #endif @@ -148,11 +126,9 @@ peekLEInt32 :: Ptr Word8 -> IO Int32 #ifdef WORDS_BIGENDIAN peekLEInt32 = - {-# SCC "peekLEInt32" #-} fmap (fromIntegral . byteSwap32) . peekStorable #else peekLEInt32 = - {-# SCC "peekLEInt32" #-} peekStorable #endif @@ -161,11 +137,9 @@ peekBEInt64 :: Ptr Word8 -> IO Int64 #ifdef WORDS_BIGENDIAN peekBEInt64 = - {-# SCC "peekBEInt64" #-} peekStorable #else peekBEInt64 = - {-# SCC "peekBEInt64" #-} fmap (fromIntegral . byteSwap64) . peekStorable #endif @@ -174,21 +148,17 @@ peekLEInt64 :: Ptr Word8 -> IO Int64 #ifdef WORDS_BIGENDIAN peekLEInt64 = - {-# SCC "peekLEInt64" #-} fmap (fromIntegral . byteSwap64) . peekStorable #else peekLEInt64 = - {-# SCC "peekLEInt64" #-} peekStorable #endif -{-| -Allocate a new byte array with @memcpy@. --} +-- | +-- Allocate a new byte array with @memcpy@. {-# INLINE peekBytes #-} peekBytes :: Ptr Word8 -> Int -> IO ByteString peekBytes ptr amount = - {-# SCC "peekBytes" #-} A.create amount $ \destPtr -> A.memcpy destPtr ptr amount {-# INLINE peekShortByteString #-} @@ -205,45 +175,55 @@ {-# INLINE pokeStorable #-} pokeStorable :: Storable a => Ptr Word8 -> a -> IO () -pokeStorable ptr value = - {-# SCC "pokeStorable" #-} - poke (castPtr ptr) value +pokeStorable = + poke . castPtr +{-# INLINE pokeStorableByteOff #-} +pokeStorableByteOff :: Storable a => Ptr Word8 -> Int -> a -> IO () +pokeStorableByteOff = + pokeByteOff . castPtr + {-# INLINE pokeWord8 #-} pokeWord8 :: Ptr Word8 -> Word8 -> IO () pokeWord8 ptr value = - {-# SCC "pokeWord8" #-} poke ptr value {-# INLINE pokeWord8Off #-} pokeWord8Off :: Ptr Word8 -> Int -> Word8 -> IO () pokeWord8Off ptr off value = - {-# SCC "pokeWord8Off" #-} pokeByteOff ptr off value {-# INLINE pokeBEWord16 #-} pokeBEWord16 :: Ptr Word8 -> Word16 -> IO () #ifdef WORDS_BIGENDIAN pokeBEWord16 = - {-# SCC "pokeBEWord16" #-} pokeStorable #else pokeBEWord16 ptr value = - {-# SCC "pokeBEWord16" #-} do pokeStorable ptr (fromIntegral (D.shiftr_w16 value 8) :: Word8) pokeByteOff ptr 1 (fromIntegral value :: Word8) #endif +{-# INLINE pokeBEWord16ByteOff #-} +pokeBEWord16ByteOff :: Ptr Word8 -> Int -> Word16 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord16ByteOff = + pokeStorableByteOff +#else +pokeBEWord16ByteOff ptr off value = + do + pokeStorableByteOff ptr off (fromIntegral (D.shiftr_w16 value 8) :: Word8) + pokeByteOff ptr (off + 1) (fromIntegral value :: Word8) +#endif + {-# INLINE pokeBEWord32 #-} pokeBEWord32 :: Ptr Word8 -> Word32 -> IO () #ifdef WORDS_BIGENDIAN pokeBEWord32 = - {-# SCC "pokeBEWord32" #-} pokeStorable #else pokeBEWord32 ptr value = - {-# SCC "pokeBEWord32" #-} do pokeStorable ptr (fromIntegral (D.shiftr_w32 value 24) :: Word8) pokeByteOff ptr 1 (fromIntegral (D.shiftr_w32 value 16) :: Word8) @@ -251,11 +231,24 @@ pokeByteOff ptr 3 (fromIntegral value :: Word8) #endif +{-# INLINE pokeBEWord32ByteOff #-} +pokeBEWord32ByteOff :: Ptr Word8 -> Int -> Word32 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord32ByteOff = + pokeStorableByteOff +#else +pokeBEWord32ByteOff ptr off value = + do + pokeStorableByteOff ptr off (fromIntegral (D.shiftr_w32 value 24) :: Word8) + pokeByteOff ptr (off + 1) (fromIntegral (D.shiftr_w32 value 16) :: Word8) + pokeByteOff ptr (off + 2) (fromIntegral (D.shiftr_w32 value 8) :: Word8) + pokeByteOff ptr (off + 3) (fromIntegral value :: Word8) +#endif + {-# INLINE pokeBEWord64 #-} pokeBEWord64 :: Ptr Word8 -> Word64 -> IO () #ifdef WORDS_BIGENDIAN pokeBEWord64 = - {-# SCC "pokeBEWord64" #-} pokeStorable #else #if WORD_SIZE_IN_BITS < 64 @@ -264,13 +257,11 @@ -- Word32, and write that -- pokeBEWord64 ptr value = - {-# SCC "pokeBEWord64" #-} do pokeBEWord32 ptr (fromIntegral (D.shiftr_w64 value 32)) pokeBEWord32 (plusPtr ptr 4) (fromIntegral value) #else pokeBEWord64 ptr value = - {-# SCC "pokeBEWord64" #-} do pokeStorable ptr (fromIntegral (D.shiftr_w64 value 56) :: Word8) pokeByteOff ptr 1 (fromIntegral (D.shiftr_w64 value 48) :: Word8) @@ -283,17 +274,44 @@ #endif #endif +{-# INLINE pokeBEWord64ByteOff #-} +pokeBEWord64ByteOff :: Ptr Word8 -> Int -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +pokeBEWord64ByteOff = + pokeStorableByteOff +#else +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +pokeBEWord64ByteOff ptr off value = + do + pokeBEWord32ByteOff ptr off (fromIntegral (D.shiftr_w64 value 32)) + pokeBEWord32ByteOff ptr (off + 4) (fromIntegral value) +#else +pokeBEWord64ByteOff ptr off value = + do + pokeStorableByteOff ptr off (fromIntegral (D.shiftr_w64 value 56) :: Word8) + pokeByteOff ptr (off + 1) (fromIntegral (D.shiftr_w64 value 48) :: Word8) + pokeByteOff ptr (off + 2) (fromIntegral (D.shiftr_w64 value 40) :: Word8) + pokeByteOff ptr (off + 3) (fromIntegral (D.shiftr_w64 value 32) :: Word8) + pokeByteOff ptr (off + 4) (fromIntegral (D.shiftr_w64 value 24) :: Word8) + pokeByteOff ptr (off + 5) (fromIntegral (D.shiftr_w64 value 16) :: Word8) + pokeByteOff ptr (off + 6) (fromIntegral (D.shiftr_w64 value 8) :: Word8) + pokeByteOff ptr (off + 7) (fromIntegral value :: Word8) +#endif +#endif + {-# INLINE pokeLEWord16 #-} pokeLEWord16 :: Ptr Word8 -> Word16 -> IO () #ifdef WORDS_BIGENDIAN pokeLEWord16 p w = - {-# SCC "pokeLEWord16" #-} do pokeWord8 p (fromIntegral w) pokeWord8Off p 1 (fromIntegral (D.shiftr_w16 w 8)) #else pokeLEWord16 = - {-# SCC "pokeLEWord16" #-} pokeStorable #endif @@ -301,7 +319,6 @@ pokeLEWord32 :: Ptr Word8 -> Word32 -> IO () #ifdef WORDS_BIGENDIAN pokeLEWord32 p w = - {-# SCC "pokeLEWord32" #-} do pokeWord8 p (fromIntegral w) pokeWord8Off p 1 (fromIntegral (D.shiftr_w32 w 8)) @@ -309,7 +326,6 @@ pokeWord8Off p 3 (fromIntegral (D.shiftr_w32 w 24)) #else pokeLEWord32 = - {-# SCC "pokeLEWord32" #-} pokeStorable #endif @@ -322,7 +338,6 @@ -- Word32, and write that -- pokeLEWord64 p w = - {-# SCC "pokeLEWord64" #-} do let b = fromIntegral (D.shiftr_w64 w 32) :: Word32 a = fromIntegral w :: Word32 @@ -336,7 +351,6 @@ pokeWord8Off p 7 (fromIntegral (D.shiftr_w32 b 24)) #else pokeLEWord64 p w = - {-# SCC "pokeLEWord64" #-} do pokeWord8 p (fromIntegral w) pokeWord8Off p 1 (fromIntegral (D.shiftr_w64 w 8)) @@ -349,18 +363,20 @@ #endif #else pokeLEWord64 = - {-# SCC "pokeLEWord64" #-} pokeStorable #endif {-# INLINE pokeBytesTrimming #-} pokeBytesTrimming :: Ptr Word8 -> Int -> ByteString -> IO () pokeBytesTrimming ptr maxLength (A.PS fptr offset length) = - {-# SCC "pokeBytesTrimming" #-} withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) (min length maxLength) {-# INLINE pokeBytes #-} pokeBytes :: Ptr Word8 -> ByteString -> IO () +#if MIN_VERSION_bytestring(0,11,0) +pokeBytes ptr (A.BS fptr length) = + withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr bytesPtr length +#else pokeBytes ptr (A.PS fptr offset length) = - {-# SCC "pokeBytes" #-} withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) length +#endif diff --git a/library/Ptr/List.hs b/library/Ptr/List.hs --- a/library/Ptr/List.hs +++ b/library/Ptr/List.hs @@ -1,13 +1,16 @@ -module Ptr.List -where +module Ptr.List where import Ptr.Prelude - {-# INLINE reverseDigits #-} -reverseDigits :: Integral a => a {-^ Radix -} -> a {-^ Number -} -> [a] +reverseDigits :: + Integral a => + -- | Radix + a -> + -- | Number + a -> + [a] reverseDigits radix = - let - loop x = case divMod x radix of - (next, digit) -> digit : if next <= 0 then [] else loop next - in loop + let loop x = case divMod x radix of + (next, digit) -> digit : if next <= 0 then [] else loop next + in loop diff --git a/library/Ptr/Parse.hs b/library/Ptr/Parse.hs --- a/library/Ptr/Parse.hs +++ b/library/Ptr/Parse.hs @@ -1,48 +1,49 @@ -module Ptr.Parse -where +module Ptr.Parse where -import Ptr.Prelude hiding (peek, take) -import qualified Ptr.PokeAndPeek as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Short.Internal as E -import qualified Ptr.Prelude as C import qualified Ptr.IO as D - +import qualified Ptr.PokeAndPeek as A +import Ptr.Prelude hiding (peek, take) +import qualified Ptr.Prelude as C -newtype Parse output = - Parse (Int -> Ptr Word8 -> forall result. (Int -> IO result) -> (Text -> IO result) -> (output -> Int -> Ptr Word8 -> IO result) -> IO result) +newtype Parse output + = Parse (Int -> Ptr Word8 -> forall result. (Int -> IO result) -> (Text -> IO result) -> (output -> Int -> Ptr Word8 -> IO result) -> IO result) deriving instance Functor Parse instance Applicative Parse where pure x = - Parse (\ availableAmount ptr _ _ succeed -> succeed x availableAmount ptr) + Parse (\availableAmount ptr _ _ succeed -> succeed x availableAmount ptr) {-# INLINE (<*>) #-} (<*>) (Parse left) (Parse right) = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - left availableAmount ptr failWithEOI failWithMessage $ \ leftOutput !leftAvailableAmount !leftPtr -> - right leftAvailableAmount leftPtr failWithEOI failWithMessage $ \ rightOutput !rightAvailableAmount !rightPtr -> - succeed (leftOutput rightOutput) rightAvailableAmount rightPtr + left availableAmount ptr failWithEOI failWithMessage $ \leftOutput !leftAvailableAmount !leftPtr -> + right leftAvailableAmount leftPtr failWithEOI failWithMessage $ \rightOutput !rightAvailableAmount !rightPtr -> + succeed (leftOutput rightOutput) rightAvailableAmount rightPtr instance Alternative Parse where empty = - Parse (\ _ _ failWithEOI _ _ -> failWithEOI 0) + Parse (\_ _ failWithEOI _ _ -> failWithEOI 0) {-# INLINE (<|>) #-} (<|>) (Parse left) (Parse right) = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - left availableAmount ptr - (\ _ -> right availableAmount ptr failWithEOI failWithMessage succeed) - failWithMessage succeed + left + availableAmount + ptr + (\_ -> right availableAmount ptr failWithEOI failWithMessage succeed) + failWithMessage + succeed instance Monad Parse where return = pure {-# INLINE (>>=) #-} (>>=) (Parse left) rightK = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - left availableAmount ptr failWithEOI failWithMessage $ \ leftOutput !leftAvailableAmount !leftPtr -> - case rightK leftOutput of - Parse right -> - right leftAvailableAmount leftPtr failWithEOI failWithMessage succeed + left availableAmount ptr failWithEOI failWithMessage $ \leftOutput !leftAvailableAmount !leftPtr -> + case rightK leftOutput of + Parse right -> + right leftAvailableAmount leftPtr failWithEOI failWithMessage succeed instance MonadPlus Parse where mzero = empty @@ -51,57 +52,60 @@ instance MonadIO Parse where {-# INLINE liftIO #-} liftIO io = - Parse $ \ availableAmount ptr _ _ succeed -> io >>= \ output -> succeed output availableAmount ptr + Parse $ \availableAmount ptr _ _ succeed -> io >>= \output -> succeed output availableAmount ptr {-# INLINE fail #-} fail :: Text -> Parse output fail message = - Parse $ \ _ _ _ failWithMessage _ -> failWithMessage message + Parse $ \_ _ _ failWithMessage _ -> failWithMessage message {-# INLINE io #-} io :: Int -> (Ptr Word8 -> IO output) -> Parse output io !requiredAmount ptrIO = - {-# SCC "io" #-} + {-# SCC "io" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - if availableAmount >= requiredAmount - then do - !result <- ptrIO ptr - succeed result (availableAmount - requiredAmount) (plusPtr ptr requiredAmount) - else failWithEOI (requiredAmount - availableAmount) + if availableAmount >= requiredAmount + then do + !result <- ptrIO ptr + succeed result (availableAmount - requiredAmount) (plusPtr ptr requiredAmount) + else failWithEOI (requiredAmount - availableAmount) {-# INLINE mapInIO #-} mapInIO :: (output -> IO newOutput) -> Parse output -> Parse newOutput mapInIO io (Parse parseIO) = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - parseIO availableAmount ptr failWithEOI failWithMessage - (\ output newAvailableAmount newPtr -> io output >>= \ newOutput -> succeed newOutput newAvailableAmount newPtr) + parseIO + availableAmount + ptr + failWithEOI + failWithMessage + (\output newAvailableAmount newPtr -> io output >>= \newOutput -> succeed newOutput newAvailableAmount newPtr) {-# INLINE pokeAndPeek #-} pokeAndPeek :: A.PokeAndPeek input output -> Parse output pokeAndPeek (A.PokeAndPeek requiredAmount _ ptrIO) = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - if availableAmount >= requiredAmount - then do - !result <- ptrIO ptr - succeed result (availableAmount - requiredAmount) (plusPtr ptr requiredAmount) - else failWithEOI (requiredAmount - availableAmount) + if availableAmount >= requiredAmount + then do + !result <- ptrIO ptr + succeed result (availableAmount - requiredAmount) (plusPtr ptr requiredAmount) + else failWithEOI (requiredAmount - availableAmount) {-# INLINE limiting #-} limiting :: Int -> Parse output -> Parse output limiting limitAmount (Parse io) = Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - if availableAmount >= limitAmount - then io limitAmount ptr failWithEOI failWithMessage succeed - else failWithEOI (limitAmount - availableAmount) + if availableAmount >= limitAmount + then io limitAmount ptr failWithEOI failWithMessage succeed + else failWithEOI (limitAmount - availableAmount) -{-| -Decode the remaining bytes, whithout moving the parser's cursor. -Useful for debugging. --} +-- | +-- Decode the remaining bytes, whithout moving the parser's cursor. +-- Useful for debugging. {-# INLINE peekRemainders #-} peekRemainders :: Parse ByteString peekRemainders = - {-# SCC "peekRemainders" #-} + {-# SCC "peekRemainders" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do !bytes <- D.peekBytes ptr availableAmount succeed bytes availableAmount ptr @@ -109,37 +113,37 @@ {-# INLINE word8 #-} word8 :: Parse Word8 word8 = - {-# SCC "word8" #-} + {-# SCC "word8" #-} io 1 D.peekWord8 {-# INLINE beWord16 #-} beWord16 :: Parse Word16 beWord16 = - {-# SCC "beWord16" #-} + {-# SCC "beWord16" #-} io 2 D.peekBEWord16 {-# INLINE beWord32 #-} beWord32 :: Parse Word32 beWord32 = - {-# SCC "beWord32" #-} + {-# SCC "beWord32" #-} io 4 D.peekBEWord32 {-# INLINE beWord64 #-} beWord64 :: Parse Word64 beWord64 = - {-# SCC "beWord64" #-} + {-# SCC "beWord64" #-} io 8 D.peekBEWord64 {-# INLINE bytes #-} bytes :: Int -> Parse ByteString bytes amount = - {-# SCC "bytes" #-} - io amount (\ ptr -> D.peekBytes ptr amount) + {-# SCC "bytes" #-} + io amount (\ptr -> D.peekBytes ptr amount) {-# INLINE allBytes #-} allBytes :: Parse ByteString allBytes = - {-# SCC "allBytes" #-} + {-# SCC "allBytes" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do !bytes <- D.peekBytes ptr availableAmount succeed bytes 0 (plusPtr ptr availableAmount) @@ -151,80 +155,78 @@ Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do !bytes <- B.packCString (castPtr ptr) case succ (B.length bytes) of - consumedAmount -> if consumedAmount <= availableAmount - then succeed bytes (availableAmount - consumedAmount) (plusPtr ptr consumedAmount) - else failWithEOI (consumedAmount - availableAmount) + consumedAmount -> + if consumedAmount <= availableAmount + then succeed bytes (availableAmount - consumedAmount) (plusPtr ptr consumedAmount) + else failWithEOI (consumedAmount - availableAmount) {-# INLINE nullTerminatedShortByteString #-} nullTerminatedShortByteString :: Parse ShortByteString nullTerminatedShortByteString = {-# SCC "nullTerminatedShortByteString" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - D.peekNullTerminatedShortByteString ptr $ \ length create -> - if length <= availableAmount - then do - !result <- create - succeed result (availableAmount - length) (plusPtr ptr length) - else failWithEOI (length - availableAmount) + D.peekNullTerminatedShortByteString ptr $ \length create -> + if length <= availableAmount + then do + !result <- create + succeed result (availableAmount - length) (plusPtr ptr length) + else failWithEOI (length - availableAmount) {-# INLINE bytesWhile #-} bytesWhile :: (Word8 -> Bool) -> Parse ByteString bytesWhile predicate = {-# SCC "bytesWhile" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - let - iterate !availableAmount !unconsumedAmount !currentPtr = - if unconsumedAmount > 0 - then do - byte <- C.peek currentPtr - if predicate byte - then iterate availableAmount (pred unconsumedAmount) (plusPtr currentPtr 1) + let iterate !availableAmount !unconsumedAmount !currentPtr = + if unconsumedAmount > 0 + then do + byte <- C.peek currentPtr + if predicate byte + then iterate availableAmount (pred unconsumedAmount) (plusPtr currentPtr 1) + else do + bytes <- B.packCStringLen (castPtr ptr, availableAmount - unconsumedAmount) + succeed bytes unconsumedAmount currentPtr else do bytes <- B.packCStringLen (castPtr ptr, availableAmount - unconsumedAmount) succeed bytes unconsumedAmount currentPtr - else do - bytes <- B.packCStringLen (castPtr ptr, availableAmount - unconsumedAmount) - succeed bytes unconsumedAmount currentPtr - in iterate availableAmount availableAmount ptr + in iterate availableAmount availableAmount ptr {-# INLINE skipWhile #-} skipWhile :: (Word8 -> Bool) -> Parse () skipWhile predicate = - {-# SCC "skipWhile" #-} + {-# SCC "skipWhile" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - let - iterate !availableAmount !unconsumedAmount !ptr = - if unconsumedAmount > 0 - then do - byte <- C.peek ptr - if predicate byte - then iterate availableAmount (pred unconsumedAmount) (plusPtr ptr 1) + let iterate !availableAmount !unconsumedAmount !ptr = + if unconsumedAmount > 0 + then do + byte <- C.peek ptr + if predicate byte + then iterate availableAmount (pred unconsumedAmount) (plusPtr ptr 1) + else succeed () unconsumedAmount ptr else succeed () unconsumedAmount ptr - else succeed () unconsumedAmount ptr - in iterate availableAmount availableAmount ptr + in iterate availableAmount availableAmount ptr {-# INLINE foldWhile #-} foldWhile :: (Word8 -> Bool) -> (state -> Word8 -> state) -> state -> Parse state foldWhile predicate step start = - {-# SCC "foldWhile" #-} + {-# SCC "foldWhile" #-} Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> - let - iterate !state !unconsumedAmount !ptr = - if unconsumedAmount > 0 - then do - byte <- C.peek ptr - if predicate byte - then iterate (step state byte) (pred unconsumedAmount) (plusPtr ptr 1) - else succeed state unconsumedAmount ptr - else failWithEOI 0 - in iterate start availableAmount ptr + let iterate !state !unconsumedAmount !ptr = + if unconsumedAmount > 0 + then do + byte <- C.peek ptr + if predicate byte + then iterate (step state byte) (pred unconsumedAmount) (plusPtr ptr 1) + else succeed state unconsumedAmount ptr + else failWithEOI 0 + in iterate start availableAmount ptr -- | -- Unsigned integral number encoded in ASCII. {-# INLINE unsignedASCIIIntegral #-} unsignedASCIIIntegral :: Integral a => Parse a unsignedASCIIIntegral = - {-# SCC "unsignedASCIIIntegral" #-} + {-# SCC "unsignedASCIIIntegral" #-} foldWhile byteIsDigit step 0 where byteIsDigit byte = diff --git a/library/Ptr/ParseUnbound.hs b/library/Ptr/ParseUnbound.hs --- a/library/Ptr/ParseUnbound.hs +++ b/library/Ptr/ParseUnbound.hs @@ -1,92 +1,89 @@ -module Ptr.ParseUnbound -where +module Ptr.ParseUnbound where -import Ptr.Prelude hiding (peek, take) -import qualified Ptr.PokeAndPeek as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Short.Internal as E -import qualified Ptr.Prelude as C import qualified Ptr.IO as D - +import qualified Ptr.PokeAndPeek as A +import Ptr.Prelude hiding (peek, take) +import qualified Ptr.Prelude as C -{-| -Unbound parser, whose peeking action decides how much input to consume, -and merely informs the executor about how many bytes it consumed. --} -newtype ParseUnbound output = - ParseUnbound (Ptr Word8 -> forall result. (Text -> IO result) -> (output -> Int -> IO result) -> IO result) +-- | +-- Unbound parser, whose peeking action decides how much input to consume, +-- and merely informs the executor about how many bytes it consumed. +newtype ParseUnbound output + = ParseUnbound (Ptr Word8 -> forall result. (Text -> IO result) -> (output -> Int -> IO result) -> IO result) deriving instance Functor ParseUnbound instance Applicative ParseUnbound where pure x = - ParseUnbound (\ ptr _ succeed -> succeed x 0) + ParseUnbound (\ptr _ succeed -> succeed x 0) {-# INLINE (<*>) #-} (<*>) (ParseUnbound left) (ParseUnbound right) = - ParseUnbound $ \ ptr fail succeed -> - left ptr fail $ \ leftOutput leftSize -> - right (plusPtr ptr leftSize) fail $ \ rightOutput rightSize -> - succeed (leftOutput rightOutput) (leftSize + rightSize) + ParseUnbound $ \ptr fail succeed -> + left ptr fail $ \leftOutput leftSize -> + right (plusPtr ptr leftSize) fail $ \rightOutput rightSize -> + succeed (leftOutput rightOutput) (leftSize + rightSize) instance Monad ParseUnbound where return = pure {-# INLINE (>>=) #-} (>>=) (ParseUnbound left) rightK = - ParseUnbound $ \ ptr fail succeed -> - left ptr fail $ \ leftOutput leftSize -> - case rightK leftOutput of - ParseUnbound right -> - right (plusPtr ptr leftSize) fail succeed + ParseUnbound $ \ptr fail succeed -> + left ptr fail $ \leftOutput leftSize -> + case rightK leftOutput of + ParseUnbound right -> + right (plusPtr ptr leftSize) fail succeed {-# INLINE fail #-} fail :: Text -> ParseUnbound output fail message = - ParseUnbound $ \ _ fail _ -> fail message + ParseUnbound $ \_ fail _ -> fail message {-# INLINE io #-} io :: Int -> (Ptr Word8 -> IO output) -> ParseUnbound output io !size ptrIO = - {-# SCC "io" #-} - ParseUnbound $ \ ptr fail succeed -> do + {-# SCC "io" #-} + ParseUnbound $ \ptr fail succeed -> do !result <- ptrIO ptr succeed result size {-# INLINE pokeAndPeek #-} pokeAndPeek :: A.PokeAndPeek input output -> ParseUnbound output pokeAndPeek (A.PokeAndPeek size _ ptrIO) = - ParseUnbound $ \ ptr fail succeed -> do + ParseUnbound $ \ptr fail succeed -> do !result <- ptrIO ptr succeed result size {-# INLINE word8 #-} word8 :: ParseUnbound Word8 word8 = - {-# SCC "word8" #-} + {-# SCC "word8" #-} io 1 D.peekWord8 {-# INLINE beWord16 #-} beWord16 :: ParseUnbound Word16 beWord16 = - {-# SCC "beWord16" #-} + {-# SCC "beWord16" #-} io 2 D.peekBEWord16 {-# INLINE beWord32 #-} beWord32 :: ParseUnbound Word32 beWord32 = - {-# SCC "beWord32" #-} + {-# SCC "beWord32" #-} io 4 D.peekBEWord32 {-# INLINE beWord64 #-} beWord64 :: ParseUnbound Word64 beWord64 = - {-# SCC "beWord64" #-} + {-# SCC "beWord64" #-} io 8 D.peekBEWord64 {-# INLINE bytes #-} bytes :: Int -> ParseUnbound ByteString bytes amount = - {-# SCC "bytes" #-} - io amount (\ ptr -> D.peekBytes ptr amount) + {-# SCC "bytes" #-} + io amount (\ptr -> D.peekBytes ptr amount) {-# INLINE nullTerminatedBytes #-} nullTerminatedBytes :: ParseUnbound ByteString @@ -101,61 +98,58 @@ nullTerminatedShortByteString = {-# SCC "nullTerminatedShortByteString" #-} ParseUnbound $ \ !ptr fail succeed -> - D.peekNullTerminatedShortByteString ptr $ \ !length create -> - do - !bytes <- create - succeed bytes length + D.peekNullTerminatedShortByteString ptr $ \ !length create -> + do + !bytes <- create + succeed bytes length {-# INLINE bytesWhile #-} bytesWhile :: (Word8 -> Bool) -> ParseUnbound ByteString bytesWhile predicate = {-# SCC "bytesWhile" #-} - ParseUnbound $ \ ptr fail succeed -> - let - iterate !i = - do - byte <- C.peek (plusPtr ptr i) - if predicate byte - then iterate (succ i) - else do - bytes <- B.packCStringLen (castPtr ptr, i) - succeed bytes i - in iterate 0 + ParseUnbound $ \ptr fail succeed -> + let iterate !i = + do + byte <- C.peek (plusPtr ptr i) + if predicate byte + then iterate (succ i) + else do + bytes <- B.packCStringLen (castPtr ptr, i) + succeed bytes i + in iterate 0 {-# INLINE skipWhile #-} skipWhile :: (Word8 -> Bool) -> ParseUnbound () skipWhile predicate = - {-# SCC "skipWhile" #-} - ParseUnbound $ \ ptr fail succeed -> - let - iterate !i = - do - byte <- C.peek (plusPtr ptr i) - if predicate byte - then iterate (succ i) - else succeed () i - in iterate 0 + {-# SCC "skipWhile" #-} + ParseUnbound $ \ptr fail succeed -> + let iterate !i = + do + byte <- C.peek (plusPtr ptr i) + if predicate byte + then iterate (succ i) + else succeed () i + in iterate 0 {-# INLINE foldWhile #-} foldWhile :: (Word8 -> Bool) -> (state -> Word8 -> state) -> state -> ParseUnbound state foldWhile predicate step start = - {-# SCC "foldWhile" #-} - ParseUnbound $ \ ptr fail succeed -> - let - iterate !state !i = - do - byte <- C.peek (plusPtr ptr i) - if predicate byte - then iterate (step state byte) (succ i) - else succeed state i - in iterate start 0 + {-# SCC "foldWhile" #-} + ParseUnbound $ \ptr fail succeed -> + let iterate !state !i = + do + byte <- C.peek (plusPtr ptr i) + if predicate byte + then iterate (step state byte) (succ i) + else succeed state i + in iterate start 0 -- | -- Unsigned integral number encoded in ASCII. {-# INLINE unsignedASCIIIntegral #-} unsignedASCIIIntegral :: Integral a => ParseUnbound a unsignedASCIIIntegral = - {-# SCC "unsignedASCIIIntegral" #-} + {-# SCC "unsignedASCIIIntegral" #-} foldWhile byteIsDigit step 0 where byteIsDigit byte = diff --git a/library/Ptr/Peek.hs b/library/Ptr/Peek.hs --- a/library/Ptr/Peek.hs +++ b/library/Ptr/Peek.hs @@ -1,15 +1,13 @@ -module Ptr.Peek -where +module Ptr.Peek where -import Ptr.Prelude hiding (take) -import qualified Ptr.PokeAndPeek as B +import qualified Ptr.IO as A import qualified Ptr.Parse as C import qualified Ptr.ParseUnbound as D -import qualified Ptr.IO as A - +import qualified Ptr.PokeAndPeek as B +import Ptr.Prelude hiding (take) -data Peek output = - Peek {-# UNPACK #-} !Int !(Ptr Word8 -> IO output) +data Peek output + = Peek {-# UNPACK #-} !Int !(Ptr Word8 -> IO output) instance Functor Peek where {-# INLINE fmap #-} @@ -27,84 +25,158 @@ io ptr = leftIO ptr <*> rightIO (plusPtr ptr leftSize) +------------------------- +{-# INLINE int8 #-} +int8 :: Peek Int8 +int8 = + {-# SCC "int8" #-} + Peek 1 A.peekStorable + +------------------------- + +{-# INLINE beInt16 #-} +beInt16 :: Peek Int16 +beInt16 = + {-# SCC "beInt16" #-} + Peek 2 A.peekBEInt16 + +{-# INLINE beInt32 #-} +beInt32 :: Peek Int32 +beInt32 = + {-# SCC "beInt32" #-} + Peek 4 A.peekBEInt32 + +{-# INLINE beInt64 #-} +beInt64 :: Peek Int64 +beInt64 = + {-# SCC "beInt64" #-} + Peek 8 A.peekBEInt64 + +------------------------- + +{-# INLINE leInt16 #-} +leInt16 :: Peek Int16 +leInt16 = + {-# SCC "leInt16" #-} + Peek 2 A.peekLEInt16 + +{-# INLINE leInt32 #-} +leInt32 :: Peek Int32 +leInt32 = + {-# SCC "leInt32" #-} + Peek 4 A.peekLEInt32 + +{-# INLINE leInt64 #-} +leInt64 :: Peek Int64 +leInt64 = + {-# SCC "leInt64" #-} + Peek 8 A.peekLEInt64 + +------------------------- + {-# INLINE word8 #-} word8 :: Peek Word8 word8 = - {-# SCC "word8" #-} + {-# SCC "word8" #-} Peek 1 A.peekWord8 +------------------------- + {-# INLINE beWord16 #-} beWord16 :: Peek Word16 beWord16 = - {-# SCC "beWord16" #-} + {-# SCC "beWord16" #-} Peek 2 A.peekBEWord16 {-# INLINE beWord32 #-} beWord32 :: Peek Word32 beWord32 = - {-# SCC "beWord32" #-} + {-# SCC "beWord32" #-} Peek 4 A.peekBEWord32 {-# INLINE beWord64 #-} beWord64 :: Peek Word64 beWord64 = - {-# SCC "beWord64" #-} + {-# SCC "beWord64" #-} Peek 8 A.peekBEWord64 +------------------------- + +{-# INLINE leWord16 #-} +leWord16 :: Peek Word16 +leWord16 = + {-# SCC "leWord16" #-} + Peek 2 A.peekLEWord16 + +{-# INLINE leWord32 #-} +leWord32 :: Peek Word32 +leWord32 = + {-# SCC "leWord32" #-} + Peek 4 A.peekLEWord32 + +{-# INLINE leWord64 #-} +leWord64 :: Peek Word64 +leWord64 = + {-# SCC "leWord64" #-} + Peek 8 A.peekLEWord64 + +------------------------- + {-# INLINE bytes #-} bytes :: Int -> Peek ByteString bytes !amount = - {-# SCC "bytes" #-} - Peek amount (\ ptr -> A.peekBytes ptr amount) + {-# SCC "bytes" #-} + Peek amount (\ptr -> A.peekBytes ptr amount) {-# INLINE shortByteString #-} shortByteString :: Int -> Peek ShortByteString shortByteString !amount = - {-# SCC "shortByteString" #-} - Peek amount (\ ptr -> A.peekShortByteString ptr amount) + {-# SCC "shortByteString" #-} + Peek amount (\ptr -> A.peekShortByteString ptr amount) {-# INLINE pokeAndPeek #-} pokeAndPeek :: B.PokeAndPeek input output -> Peek output pokeAndPeek (B.PokeAndPeek size _ io) = - {-# SCC "pokeAndPeek" #-} + {-# SCC "pokeAndPeek" #-} Peek size io -{-| -Given the length of the data and a specification of its sequential consumption, -produces Peek, which results in Just the successfully taken value, -or Nothing, if the specified length of data wasn't enough. --} +-- | +-- Given the length of the data and a specification of its sequential consumption, +-- produces Peek, which results in Just the successfully taken value, +-- or Nothing, if the specified length of data wasn't enough. {-# INLINE parse #-} parse :: Int -> C.Parse a -> (Int -> a) -> (Text -> a) -> Peek a parse amount (C.Parse parseIO) eoi error = - {-# SCC "parse" #-} - Peek amount $ \ ptr -> - parseIO amount ptr (return . eoi) (return . error) (\result _ _ -> return result) + {-# SCC "parse" #-} + Peek amount $ \ptr -> + parseIO amount ptr (return . eoi) (return . error) (\result _ _ -> return result) -{-| -Given the length of the data and a specification of its sequential consumption, -produces Peek, which results in Just the successfully taken value, -or Nothing, if the specified length of data wasn't enough. --} +-- | +-- Given the length of the data and a specification of its sequential consumption, +-- produces Peek, which results in Just the successfully taken value, +-- or Nothing, if the specified length of data wasn't enough. {-# INLINE parseUnbound #-} parseUnbound :: Int -> D.ParseUnbound a -> (Int -> a) -> (Text -> a) -> Peek a parseUnbound sizeBound (D.ParseUnbound parseIO) eoi error = - {-# SCC "parse" #-} - Peek sizeBound $ \ ptr -> - parseIO ptr (return . error) - (\ result size -> if size <= sizeBound - then return (eoi (size - sizeBound)) - else return result) - -{-| -A standard idiom, where a header specifies the length of the body. + {-# SCC "parse" #-} + Peek sizeBound $ \ptr -> + parseIO + ptr + (return . error) + ( \result size -> + if size <= sizeBound + then return (eoi (size - sizeBound)) + else return result + ) -Produces Peek, which itself produces another Peek, which is the same as the result of the 'parse' function. --} +-- | +-- A standard idiom, where a header specifies the length of the body. +-- +-- Produces Peek, which itself produces another Peek, which is the same as the result of the 'parse' function. {-# INLINE peekAmountAndParse #-} peekAmountAndParse :: Peek Int -> C.Parse a -> (Int -> a) -> (Text -> a) -> Peek (Peek a) peekAmountAndParse peekAmount parse_ eoi error = - {-# SCC "peekAmountAndParse" #-} + {-# SCC "peekAmountAndParse" #-} flip fmap peekAmount $ \amount -> - parse amount parse_ eoi error + parse amount parse_ eoi error diff --git a/library/Ptr/Poke.hs b/library/Ptr/Poke.hs --- a/library/Ptr/Poke.hs +++ b/library/Ptr/Poke.hs @@ -1,16 +1,13 @@ -module Ptr.Poke -where +module Ptr.Poke where -import Ptr.Prelude -import qualified Ptr.PokeAndPeek as B import qualified Data.Vector as F - +import qualified Ptr.PokeAndPeek as B +import Ptr.Prelude -{-| -Specification of a sized and errorless writing action to a pointer. --} -data Poke input = - Poke !Int !(Ptr Word8 -> input -> IO ()) +-- | +-- Specification of a sized and errorless writing action to a pointer. +data Poke input + = Poke !Int !(Ptr Word8 -> input -> IO ()) instance Contravariant Poke where {-# INLINE contramap #-} @@ -25,7 +22,6 @@ divide fn (Poke size1 io1) (Poke size2 io2) = Poke (size1 + size2) (\ptr input -> case fn input of (input1, input2) -> io1 ptr input1 *> io2 (plusPtr ptr size1) input2) - {-# INLINE word8 #-} word8 :: Poke Word8 word8 = @@ -84,7 +80,7 @@ {-# INLINE asciiHexDigit #-} asciiHexDigit :: Poke Word8 asciiHexDigit = - contramap (\ n -> if n < 10 then 48 + n else 55 + n) word8 + contramap (\n -> if n < 10 then 48 + n else 55 + n) word8 {-# INLINE vector #-} vector :: Int -> Poke element -> Poke (F.Vector element) diff --git a/library/Ptr/PokeAndPeek.hs b/library/Ptr/PokeAndPeek.hs --- a/library/Ptr/PokeAndPeek.hs +++ b/library/Ptr/PokeAndPeek.hs @@ -1,30 +1,26 @@ -module Ptr.PokeAndPeek -where +module Ptr.PokeAndPeek where -import Ptr.Prelude import qualified Ptr.IO as A - - -{-| -Encoder and decoder of the same binary representation. - -You can compose both the covariant and contravariant parameters of PokeAndPeek -using Applicative and Profunctor. E.g., - ->word8AndWord32 :: PokeAndPeek (Word8, Word32) (Word8, Word32) ->word8AndWord32 = -> (,) <$> lmap fst word8 <*> lmap snd beWord32 --} -data PokeAndPeek input output = - PokeAndPeek !Int (Ptr Word8 -> input -> IO ()) (Ptr Word8 -> IO output) +import Ptr.Prelude -{-| -A codec, which encodes and decodes the same type. E.g., +-- | +-- Encoder and decoder of the same binary representation. +-- +-- You can compose both the covariant and contravariant parameters of PokeAndPeek +-- using Applicative and Profunctor. E.g., +-- +-- >word8AndWord32 :: PokeAndPeek (Word8, Word32) (Word8, Word32) +-- >word8AndWord32 = +-- > (,) <$> lmap fst word8 <*> lmap snd beWord32 +data PokeAndPeek input output + = PokeAndPeek !Int (Ptr Word8 -> input -> IO ()) (Ptr Word8 -> IO output) ->word8AndWord32 :: InvPokeAndPeek (Word8, Word32) ->word8AndWord32 = -> (,) <$> lmap fst word8 <*> lmap snd beWord32 --} +-- | +-- A codec, which encodes and decodes the same type. E.g., +-- +-- >word8AndWord32 :: InvPokeAndPeek (Word8, Word32) +-- >word8AndWord32 = +-- > (,) <$> lmap fst word8 <*> lmap snd beWord32 type InvPokeAndPeek value = PokeAndPeek value value @@ -54,47 +50,47 @@ {-# INLINE word8 #-} word8 :: InvPokeAndPeek Word8 word8 = - {-# SCC "word8" #-} + {-# SCC "word8" #-} PokeAndPeek 1 A.pokeWord8 A.peekWord8 {-# INLINE leWord16 #-} leWord16 :: InvPokeAndPeek Word16 leWord16 = - {-# SCC "leWord16" #-} + {-# SCC "leWord16" #-} PokeAndPeek 2 A.pokeLEWord16 A.peekLEWord16 {-# INLINE leWord32 #-} leWord32 :: InvPokeAndPeek Word32 leWord32 = - {-# SCC "leWord32" #-} + {-# SCC "leWord32" #-} PokeAndPeek 4 A.pokeLEWord32 A.peekLEWord32 {-# INLINE leWord64 #-} leWord64 :: InvPokeAndPeek Word64 leWord64 = - {-# SCC "leWord64" #-} + {-# SCC "leWord64" #-} PokeAndPeek 8 A.pokeLEWord64 A.peekLEWord64 {-# INLINE beWord16 #-} beWord16 :: InvPokeAndPeek Word16 beWord16 = - {-# SCC "beWord16" #-} + {-# SCC "beWord16" #-} PokeAndPeek 2 A.pokeBEWord16 A.peekBEWord16 {-# INLINE beWord32 #-} beWord32 :: InvPokeAndPeek Word32 beWord32 = - {-# SCC "beWord32" #-} + {-# SCC "beWord32" #-} PokeAndPeek 4 A.pokeBEWord32 A.peekBEWord32 {-# INLINE beWord64 #-} beWord64 :: InvPokeAndPeek Word64 beWord64 = - {-# SCC "beWord64" #-} + {-# SCC "beWord64" #-} PokeAndPeek 8 A.pokeBEWord64 A.peekBEWord64 {-# INLINE bytes #-} bytes :: Int -> InvPokeAndPeek ByteString bytes amount = - {-# SCC "bytes" #-} + {-# SCC "bytes" #-} PokeAndPeek amount (\ptr -> A.pokeBytesTrimming ptr amount) (\ptr -> A.peekBytes ptr amount) diff --git a/library/Ptr/PokeIO.hs b/library/Ptr/PokeIO.hs --- a/library/Ptr/PokeIO.hs +++ b/library/Ptr/PokeIO.hs @@ -1,12 +1,9 @@ -{-| -Sketches of new module, which implements the poking actions. --} -module Ptr.PokeIO -where +-- | +-- Sketches of new module, which implements the poking actions. +module Ptr.PokeIO where -import Ptr.Prelude import qualified Ptr.IO as IO - +import Ptr.Prelude type PokeIO = Ptr Word8 -> IO () @@ -27,26 +24,25 @@ action2 (plusPtr ptr space1) takeMVar lock -{-| Unsigned ASCII integral -} +-- | Unsigned ASCII integral {-# INLINE asciiUnsignedIntegral #-} asciiUnsignedIntegral :: (Integral a) => Int -> a -> PokeIO -asciiUnsignedIntegral = let - loop ptr x = case quotRem x 10 of - (quot, rem) -> do - IO.pokeWord8 ptr (48 + fromIntegral rem) - case quot of - 0 -> return () - _ -> loop (plusPtr ptr (-1)) quot - in \ lastIndex x ptr -> loop (plusPtr ptr lastIndex) x +asciiUnsignedIntegral = + let loop ptr x = case quotRem x 10 of + (quot, rem) -> do + IO.pokeWord8 ptr (48 + fromIntegral rem) + case quot of + 0 -> return () + _ -> loop (plusPtr ptr (-1)) quot + in \lastIndex x ptr -> loop (plusPtr ptr lastIndex) x {-# INLINE reverseAsciiDigits #-} reverseAsciiDigits :: (Integral a) => Int -> [a] -> PokeIO reverseAsciiDigits index elements ptr = - let - loop ptr = - \ case - digit : tail -> do - IO.pokeWord8 ptr (48 + fromIntegral digit) - loop (plusPtr ptr (-1)) tail - _ -> return () - in loop (plusPtr ptr index) elements + let loop ptr = + \case + digit : tail -> do + IO.pokeWord8 ptr (48 + fromIntegral digit) + loop (plusPtr ptr (-1)) tail + _ -> return () + in loop (plusPtr ptr index) elements diff --git a/library/Ptr/Poking.hs b/library/Ptr/Poking.hs --- a/library/Ptr/Poking.hs +++ b/library/Ptr/Poking.hs @@ -1,37 +1,29 @@ -module Ptr.Poking -where +module Ptr.Poking where -import Ptr.Prelude hiding (length) +import qualified Data.ByteString.Internal as B +import qualified Data.List as List +import qualified Data.Vector as F +import qualified Data.Vector.Generic as GenericVector import qualified Ptr.IO as A +import qualified Ptr.List as List import qualified Ptr.Poke as C import qualified Ptr.PokeAndPeek as D import qualified Ptr.PokeIO as E -import qualified Ptr.List as List -import qualified Data.ByteString.Internal as B -import qualified Data.Vector as F -import qualified Data.Vector.Generic as GenericVector -import qualified Data.List as List - - -{-| -An efficiently composable unmaterialised specification of how to populate a pointer. +import Ptr.Prelude hiding (length) -Once composed it can be materialized into a specific data-structure like ByteString or -to directly populate a pointer in some low-level API. --} -data Poking = - {-| - * Amount of bytes the encoded data will occupy. - * Exception-free action, which populates the pointer to the encoded data. - -} - Poking !Int (Ptr Word8 -> IO ()) +-- | +-- An efficiently composable unmaterialised specification of how to populate a pointer. +-- +-- Once composed it can be materialized into a specific data-structure like ByteString or +-- to directly populate a pointer in some low-level API. +data Poking + = -- | + -- * Amount of bytes the encoded data will occupy. + -- * Exception-free action, which populates the pointer to the encoded data. + Poking !Int (Ptr Word8 -> IO ()) instance Semigroup Poking where - {-| - When the pokings are both larger than 2048 bits, - the serialization is performed concurrently. - -} - {-# INLINABLE (<>) #-} + {-# INLINEABLE (<>) #-} (<>) (Poking space1 action1) (Poking space2 action2) = Poking (space1 + space2) action where @@ -49,9 +41,11 @@ (<>) instance IsString Poking where - fromString string = Poking (List.length string) io where - io ptr = foldM_ step ptr string where - step ptr char = A.pokeWord8 ptr (fromIntegral (ord char)) $> plusPtr ptr 1 + fromString string = Poking (List.length string) io + where + io ptr = foldM_ step ptr string + where + step ptr char = A.pokeWord8 ptr (fromIntegral (ord char)) $> plusPtr ptr 1 {-# INLINE null #-} null :: Poking -> Bool @@ -113,23 +107,23 @@ pokeAndPeek (D.PokeAndPeek space poke _) input = Poking space (\ptr -> poke ptr input) -{-| Unsigned ASCII integral -} +-- | Unsigned ASCII integral {-# INLINE asciiIntegral #-} asciiIntegral :: (Integral a) => a -> Poking -asciiIntegral = \ case +asciiIntegral = \case 0 -> word8 48 - x -> let - reverseDigits = List.reverseDigits 10 x - size = List.length reverseDigits - action = E.reverseAsciiDigits (pred size) reverseDigits - in Poking size action + x -> + let reverseDigits = List.reverseDigits 10 x + size = List.length reverseDigits + action = E.reverseAsciiDigits (pred size) reverseDigits + in Poking size action {-# INLINE asciiChar #-} asciiChar :: Char -> Poking asciiChar = word8 . fromIntegral . ord -{-# INLINABLE asciiPaddedAndTrimmedIntegral #-} +{-# INLINEABLE asciiPaddedAndTrimmedIntegral #-} asciiPaddedAndTrimmedIntegral :: Integral a => Int -> a -> Poking asciiPaddedAndTrimmedIntegral !length !integral = if length > 0 @@ -137,25 +131,28 @@ if integral >= 0 then case quotRem integral 10 of (quot, rem) -> - asciiPaddedAndTrimmedIntegral (pred length) quot <> - word8 (48 + fromIntegral rem) + asciiPaddedAndTrimmedIntegral (pred length) quot + <> word8 (48 + fromIntegral rem) else stimes length (word8 48) else mempty -{-# INLINABLE asciiUtcTimeInIso8601 #-} +{-# INLINEABLE asciiUtcTimeInIso8601 #-} {- 2017-02-01T05:03:58Z -} asciiUtcTimeInIso8601 :: UTCTime -> Poking asciiUtcTimeInIso8601 utcTime = - asciiPaddedAndTrimmedIntegral 4 year <> word8 45 <> - asciiPaddedAndTrimmedIntegral 2 month <> word8 45 <> - asciiPaddedAndTrimmedIntegral 2 day <> - word8 84 <> - asciiPaddedAndTrimmedIntegral 2 hour <> word8 58 <> - asciiPaddedAndTrimmedIntegral 2 minute <> word8 58 <> - asciiPaddedAndTrimmedIntegral 2 (round second) <> - word8 90 + asciiPaddedAndTrimmedIntegral 4 year <> word8 45 + <> asciiPaddedAndTrimmedIntegral 2 month + <> word8 45 + <> asciiPaddedAndTrimmedIntegral 2 day + <> word8 84 + <> asciiPaddedAndTrimmedIntegral 2 hour + <> word8 58 + <> asciiPaddedAndTrimmedIntegral 2 minute + <> word8 58 + <> asciiPaddedAndTrimmedIntegral 2 (round second) + <> word8 90 where LocalTime date (TimeOfDay hour minute second) = utcToLocalTime utc utcTime (year, month, day) = toGregorian date @@ -166,11 +163,11 @@ loop mempty where loop state = - \ case + \case head : tail -> loop (state <> word8 1 <> element head) tail _ -> state <> word8 0 -{-# INLINABLE vector #-} +{-# INLINEABLE vector #-} vector :: GenericVector.Vector vector element => (element -> Poking) -> vector element -> Poking vector element vectorValue = Poking byteSize io @@ -190,19 +187,23 @@ elementIO ptr return (plusPtr ptr elementByteSize) -{-# INLINABLE intercalateVector #-} +{-# INLINEABLE intercalateVector #-} intercalateVector :: GenericVector.Vector vector element => (element -> Poking) -> Poking -> vector element -> Poking -intercalateVector element (Poking separatorLength separatorIo) vectorValue = Poking length io where - length = GenericVector.foldl' step 0 vectorValue + ((GenericVector.length vectorValue - 1) * separatorLength) where - step length elementValue = case element elementValue of - Poking elementLength _ -> length + elementLength - indexIsLast = let - lastIndex = pred (GenericVector.length vectorValue) - in (== lastIndex) - io ptr = GenericVector.ifoldM'_ step ptr vectorValue where - step ptr index elementValue = case element elementValue of - Poking elementLength elementIo -> if indexIsLast index - then elementIo ptr $> ptr - else let - ptrAfterElement = plusPtr ptr elementLength - in elementIo ptr *> separatorIo ptrAfterElement $> plusPtr ptrAfterElement separatorLength +intercalateVector element (Poking separatorLength separatorIo) vectorValue = Poking length io + where + length = GenericVector.foldl' step 0 vectorValue + ((GenericVector.length vectorValue - 1) * separatorLength) + where + step length elementValue = case element elementValue of + Poking elementLength _ -> length + elementLength + indexIsLast = + let lastIndex = pred (GenericVector.length vectorValue) + in (== lastIndex) + io ptr = GenericVector.ifoldM'_ step ptr vectorValue + where + step ptr index elementValue = case element elementValue of + Poking elementLength elementIo -> + if indexIsLast index + then elementIo ptr $> ptr + else + let ptrAfterElement = plusPtr ptr elementLength + in elementIo ptr *> separatorIo ptrAfterElement $> plusPtr ptrAfterElement separatorLength diff --git a/library/Ptr/Prelude.hs b/library/Ptr/Prelude.hs --- a/library/Ptr/Prelude.hs +++ b/library/Ptr/Prelude.hs @@ -1,25 +1,23 @@ module Ptr.Prelude -( - module Exports, -) + ( module Exports, + ) where - --- base -------------------------- -import Control.Applicative as Exports +import Control.Applicative as Exports hiding (WrappedArrow (..)) import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports -import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM) -import Control.Monad.IO.Class as Exports +import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.ByteString.Short as Exports (ShortByteString) import Data.Char as Exports import Data.Coerce as Exports import Data.Complex as Exports @@ -27,24 +25,29 @@ import Data.Dynamic as Exports import Data.Either as Exports import Data.Fixed as Exports -import Data.Foldable as Exports +import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports -import Data.Int as Exports +import Data.Functor.Contravariant.Divisible as Exports import Data.IORef as Exports +import Data.Int as Exports import Data.Ix as Exports -import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') -import Data.List.NonEmpty as Exports (NonEmpty(..)) +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports -import Data.Monoid as Exports hiding (Alt, Last(..), First(..), (<>)) +import Data.Monoid as Exports hiding (Alt, (<>)) import Data.Ord as Exports +import Data.Profunctor as Exports hiding (WrapArrow, WrappedArrow, unwrapArrow) +import Data.Profunctor.Unsafe as Exports import Data.Proxy as Exports import Data.Ratio as Exports -import Data.Semigroup as Exports import Data.STRef as Exports +import Data.Semigroup as Exports hiding (First (..), Last (..)) import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Time as Exports import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports @@ -57,12 +60,13 @@ import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports -import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) -import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports +import GHC.OverloadedLabels as Exports import Numeric as Exports -import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) +import StrictList as Exports (List (..)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose) @@ -71,31 +75,9 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) -import Text.Printf as Exports (printf, hPrintf) -import Text.Read as Exports (Read(..), readMaybe, readEither) +import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P) +import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec) +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports - --- contravariant -------------------------- -import Data.Functor.Contravariant as Exports -import Data.Functor.Contravariant.Divisible as Exports - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports -import Data.Profunctor as Exports hiding (WrappedArrow, WrapArrow, unwrapArrow) - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) -import Data.ByteString.Short as Exports (ShortByteString) - --- text -------------------------- -import Data.Text as Exports (Text) - --- time -------------------------- -import Data.Time as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) diff --git a/library/Ptr/Read.hs b/library/Ptr/Read.hs new file mode 100644 --- /dev/null +++ b/library/Ptr/Read.hs @@ -0,0 +1,286 @@ +module Ptr.Read + ( Read, + Status (..), + runOnPtr, + runOnByteString, + runOnByteStringFinishing, + skip, + skipWhile, + byteString, + byteStringWhile, + foldlWhile', + word8, + int16InBe, + int32InBe, + int64InBe, + nullTerminatedByteString, + asciiIntegral, + ) +where + +import qualified Data.ByteString.Internal as ByteString +import qualified Ptr.IO as IO +import Ptr.Prelude hiding (Read) +import qualified Ptr.Util.ByteString as ByteString +import qualified Ptr.Util.Word8Predicates as Word8Predicates +import qualified StrictList + +-- | +-- Deserializer highly optimized for reading from pointers. +-- +-- Parsing ByteString is just a special case. +newtype Read a + = Read (Ptr Word8 -> Ptr Word8 -> IO (Status a)) + +instance Functor Read where + fmap f (Read cont) = + Read (\start end -> fmap (fmap f) (cont start end)) + +instance Applicative Read where + pure a = + Read (\s e -> pure (FinishedStatus s a)) + Read lGetStatus <*> Read rGetStatus = + Read $ \start end -> do + lGetStatus start end >>= \case + FinishedStatus lAfter lRes -> + rGetStatus lAfter end & fmap (fmap lRes) + UnfinishedStatus lNextPeek -> + return (UnfinishedStatus (lNextPeek <*> Read rGetStatus)) + +instance Monad Read where + return = pure + Read lGetStatus >>= k = + Read $ \start end -> + lGetStatus start end >>= \case + FinishedStatus lAfter lRes -> + k lRes & \(Read rGetStatus) -> rGetStatus lAfter end + UnfinishedStatus lNextPeek -> + return (UnfinishedStatus (lNextPeek >>= k)) + +-- | +-- Result of a single iteration. +-- +-- Errors can be achieved by using Either for output. +data Status a + = FinishedStatus {-# UNPACK #-} !(Ptr Word8) a + | UnfinishedStatus (Read a) + deriving (Functor) + +------------------------- + +runOnPtr :: Read a -> Ptr Word8 -> Ptr Word8 -> IO (Status a) +runOnPtr = + coerce + +runOnByteString :: Read a -> ByteString -> Either (Read a) (a, ByteString) +runOnByteString (Read read) (ByteString.PS bsFp bsOff bsSize) = + unsafePerformIO $ + withForeignPtr bsFp $ \p -> + let startP = plusPtr p bsOff + endP = plusPtr startP bsSize + in read startP endP <&> \case + FinishedStatus newStartP res -> + let newBsOff = minusPtr newStartP p + newBs = ByteString.PS bsFp newBsOff (bsSize - (newBsOff - bsOff)) + in Right (res, newBs) + UnfinishedStatus next -> + Left next + +runOnByteStringFinishing :: Read a -> ByteString -> Maybe a +runOnByteStringFinishing read byteString = + runOnByteString read byteString + & either (const Nothing) (Just . fst) + +------------------------- + +skip :: + -- | + -- Amount of bytes to skip. + -- + -- __Warning:__ It is your responsibility to ensure that it is not negative. + Int -> + Read () +skip = + Read . loop + where + loop needed start end = + if post <= end + then return (FinishedStatus post ()) + else return (UnfinishedStatus (Read (loop nextNeeded))) + where + post = plusPtr start needed + nextNeeded = minusPtr post end + +skipWhile :: (Word8 -> Bool) -> Read () +skipWhile predicate = + Read loop + where + loop start end = + if post <= end + then do + w <- IO.peekWord8 start + if predicate w + then loop post end + else return (FinishedStatus start ()) + else return (UnfinishedStatus (Read loop)) + where + post = plusPtr start 1 + +byteString :: + -- | + -- Size of the bytestring. + -- + -- __Warning:__ It is your responsibility to ensure that it is not negative. + Int -> + Read ByteString +byteString totalNeededSize = + Read (collectChunks totalNeededSize Nil) + where + collectChunks neededSize chunks startPtr endPtr = + let nextPtr = plusPtr startPtr neededSize + in -- If there's enough + if nextPtr <= endPtr + then + let lastChunkLength = minusPtr nextPtr startPtr + !chunk = ByteString.fromPtr lastChunkLength startPtr + merged = ByteString.fromReverseStrictListWithHead chunk (totalNeededSize - lastChunkLength) chunks + in return (FinishedStatus nextPtr merged) + else + let lastChunkLength = minusPtr endPtr startPtr + !chunk = ByteString.fromPtr lastChunkLength startPtr + newNeededSize = neededSize - lastChunkLength + newChunks = Cons chunk chunks + loop = collectChunks newNeededSize newChunks + in return (UnfinishedStatus (Read loop)) + +byteStringWhile :: (Word8 -> Bool) -> Read ByteString +byteStringWhile predicate = + Read (collectChunks 0 Nil) + where + collectChunks totalLength chunks startPtr endPtr = + populateChunk startPtr + where + populateChunk curPtr = + if curPtr < endPtr + then do + w <- IO.peekWord8 curPtr + if predicate w + then populateChunk (plusPtr curPtr 1) + else + let chunkLength = + minusPtr curPtr startPtr + !chunk = + ByteString.fromPtr chunkLength startPtr + merged = + ByteString.fromReverseStrictListWithHead chunk totalLength chunks + in return (FinishedStatus curPtr merged) + else + let chunkLength = + minusPtr endPtr startPtr + !chunk = + ByteString.fromPtr chunkLength startPtr + newTotalLength = + totalLength + chunkLength + newChunks = + Cons chunk chunks + in return (UnfinishedStatus (Read (collectChunks newTotalLength newChunks))) + +foldlWhile' :: (Word8 -> Bool) -> (acc -> Word8 -> acc) -> acc -> Read acc +foldlWhile' predicate step = + Read . loop + where + loop !acc start end = + if post <= end + then do + w <- IO.peekWord8 start + if predicate w + then loop (step acc w) post end + else return (FinishedStatus start acc) + else return (UnfinishedStatus (Read (loop acc))) + where + post = plusPtr start 1 + +------------------------- + +word8 :: Read Word8 +word8 = + Read $ \start end -> + if end > start + then IO.peekWord8 start <&> FinishedStatus (plusPtr start 1) + else return (UnfinishedStatus word8) + +int16InBe :: Read Int16 +int16InBe = + Read inWhole + where + inWhole start end = + if inWholePost <= end + then IO.peekBEInt16 start <&> FinishedStatus inWholePost + else bytely 2 0 start end + where + inWholePost = plusPtr start 2 + bytely !needed !acc start end = + if start < end + then do + w <- IO.peekWord8 start + let newAcc = unsafeShiftL acc 8 .|. fromIntegral w + newStart = plusPtr start 1 + in if needed > 1 + then bytely (pred needed) newAcc newStart end + else return (FinishedStatus newStart newAcc) + else return (UnfinishedStatus (Read (bytely needed acc))) + +int32InBe :: Read Int32 +int32InBe = + Read inWhole + where + inWhole start end = + if inWholePost <= end + then IO.peekBEInt32 start <&> FinishedStatus inWholePost + else bytely 4 0 start end + where + inWholePost = plusPtr start 4 + bytely !needed !acc start end = + if start < end + then do + w <- IO.peekWord8 start + let newAcc = unsafeShiftL acc 8 .|. fromIntegral w + newStart = plusPtr start 1 + in if needed > 1 + then bytely (pred needed) newAcc newStart end + else return (FinishedStatus newStart newAcc) + else return (UnfinishedStatus (Read (bytely needed acc))) + +int64InBe :: Read Int64 +int64InBe = + Read inWhole + where + inWhole start end = + if inWholePost <= end + then IO.peekBEInt64 start <&> FinishedStatus inWholePost + else bytely 8 0 start end + where + inWholePost = plusPtr start 8 + bytely !needed !acc start end = + if start < end + then do + w <- IO.peekWord8 start + let newAcc = unsafeShiftL acc 8 .|. fromIntegral w + newStart = plusPtr start 1 + in if needed > 1 + then bytely (pred needed) newAcc newStart end + else return (FinishedStatus newStart newAcc) + else return (UnfinishedStatus (Read (bytely needed acc))) + +nullTerminatedByteString :: Read ByteString +nullTerminatedByteString = + byteStringWhile (/= 0) <* skip 1 + +-- | +-- Integral number encoded in ASCII. +asciiIntegral :: Integral a => Read a +asciiIntegral = + foldlWhile' Word8Predicates.asciiDigit step 0 + where + step acc byte = + acc * 10 + fromIntegral byte - 48 diff --git a/library/Ptr/Receive.hs b/library/Ptr/Receive.hs --- a/library/Ptr/Receive.hs +++ b/library/Ptr/Receive.hs @@ -1,27 +1,23 @@ module Ptr.Receive -( - Receive, - create, - peek, -) + ( Receive, + create, + peek, + ) where +import qualified Ptr.Peek as B import Ptr.Prelude hiding (peek) import qualified Ptr.Receive.Core as A -import qualified Ptr.Peek as B - -{-| -A wrapper of a receiving action, which extends it with bufferization. --} -data Receive = - {-| - * Exception-free action to receive another chunk of bytes. E.g., an exception-free wrapper of @Network.Socket.recvBuf@ - * Buffer - * Size of the buffer - * Chunk size - -} - Receive !(Ptr Word8 -> Int -> IO (Either Text Int)) !(ForeignPtr Word8) !(IORef (Int, Int)) !Int +-- | +-- A wrapper of a receiving action, which extends it with bufferization. +data Receive + = -- | + -- * Exception-free action to receive another chunk of bytes. E.g., an exception-free wrapper of @Network.Socket.recvBuf@ + -- * Buffer + -- * Size of the buffer + -- * Chunk size + Receive !(Ptr Word8 -> Int -> IO (Either Text Int)) !(ForeignPtr Word8) !(IORef (Int, Int)) !Int create :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> Int -> IO Receive create fetch chunkSize = @@ -30,11 +26,10 @@ bufferStateRef <- newIORef (0, 0) return (Receive fetch bufferFP bufferStateRef chunkSize) -{-| -Receive as many bytes as is required by the provided decoder and decode immediately. - -If all you need is just to get a 'ByteString' chunk then use the 'B.bytes' decoder. --} +-- | +-- Receive as many bytes as is required by the provided decoder and decode immediately. +-- +-- If all you need is just to get a 'ByteString' chunk then use the 'B.bytes' decoder. peek :: Receive -> B.Peek peekd -> IO (Either Text peekd) peek (Receive fetch bufferFP bufferStateRef chunkSize) (B.Peek amount action) = A.peek fetch bufferFP bufferStateRef chunkSize amount action diff --git a/library/Ptr/Receive/Core.hs b/library/Ptr/Receive/Core.hs --- a/library/Ptr/Receive/Core.hs +++ b/library/Ptr/Receive/Core.hs @@ -1,58 +1,47 @@ -module Ptr.Receive.Core -where +module Ptr.Receive.Core where -import Ptr.Prelude import qualified Data.ByteString.Internal as A - +import Ptr.Prelude write :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ()) write fetch bufferFP bufferStateRef chunkSize howMany destination = do (offset, end) <- readIORef bufferStateRef if end == offset - then - -- Buffer is empty, we need to fetch right away + then -- Buffer is empty, we need to fetch right away fetchMany fetch bufferFP bufferStateRef chunkSize howMany destination - else - -- We still have something in the buffer, so we'll read from it first - withForeignPtr bufferFP $ \bufferPtr -> - let - amountInBuffer = end - offset - in if amountInBuffer >= howMany - then - -- Buffer contains all we need, so we don't need to fetch at all + else -- We still have something in the buffer, so we'll read from it first + withForeignPtr bufferFP $ \bufferPtr -> + let amountInBuffer = end - offset + in if amountInBuffer >= howMany + then -- Buffer contains all we need, so we don't need to fetch at all do A.memcpy destination (plusPtr bufferPtr offset) howMany writeIORef bufferStateRef (offset + howMany, end) return (Right ()) - else - do + else do A.memcpy destination (plusPtr bufferPtr offset) amountInBuffer fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr destination amountInBuffer) fetchMany :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ()) fetchMany fetch bufferFP bufferStateRef chunkSize remaining destination = if remaining >= chunkSize - then - -- Circumvent the buffer and write to destination directly - fetchingSome destination chunkSize $ \amountFetched -> + then -- Circumvent the buffer and write to destination directly + fetchingSome destination chunkSize $ \amountFetched -> if amountFetched == remaining - then - -- We've fetched all we've wanted, time to stop - do - writeIORef bufferStateRef (0, 0) - return (Right ()) - else - -- Go on and get some more + then -- We've fetched all we've wanted, time to stop + do + writeIORef bufferStateRef (0, 0) + return (Right ()) + else -- Go on and get some more fetchMany fetch bufferFP bufferStateRef chunkSize (remaining - amountFetched) (plusPtr destination amountFetched) - else - -- Write to buffer first and then stream a part of it to the destination - withForeignPtr bufferFP $ \bufferPtr -> + else -- Write to buffer first and then stream a part of it to the destination + withForeignPtr bufferFP $ \bufferPtr -> fetchingSome bufferPtr chunkSize $ \amountFetched -> - do - A.memcpy destination bufferPtr remaining - writeIORef bufferStateRef (remaining, amountFetched) - return (Right ()) + do + A.memcpy destination bufferPtr remaining + writeIORef bufferStateRef (remaining, amountFetched) + return (Right ()) where fetchingSome destination amount handle = do @@ -68,33 +57,28 @@ peek fetch bufferFP bufferStateRef chunkSize howMany peek = do (offset, end) <- readIORef bufferStateRef - let - amountInBuffer = end - offset - in if amountInBuffer >= howMany - then - -- We have enough bytes in the buffer, so need not to allocate anything and can directly decode from the buffer + let amountInBuffer = end - offset + in if amountInBuffer >= howMany + then -- We have enough bytes in the buffer, so need not to allocate anything and can directly decode from the buffer withForeignPtr bufferFP $ \bufferPtr -> - do - peekd <- peek bufferPtr - writeIORef bufferStateRef (offset + howMany, end) - return (Right peekd) - else - -- We have to allocate a temporary space to prefetch the data into + do + peekd <- peek bufferPtr + writeIORef bufferStateRef (offset + howMany, end) + return (Right peekd) + else -- We have to allocate a temporary space to prefetch the data into allocaBytes howMany $ \tmpPtr -> - do - writeResult <- - if end == offset - then - -- Buffer is empty, we need to fetch right away - fetchMany fetch bufferFP bufferStateRef chunkSize howMany tmpPtr - else - -- We still have something in the buffer, so we'll read from it first + do + writeResult <- + if end == offset + then -- Buffer is empty, we need to fetch right away + fetchMany fetch bufferFP bufferStateRef chunkSize howMany tmpPtr + else -- We still have something in the buffer, so we'll read from it first withForeignPtr bufferFP $ \bufferPtr -> - do - A.memcpy tmpPtr (plusPtr bufferPtr offset) amountInBuffer - fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr tmpPtr amountInBuffer) - case writeResult of - Right () -> do - peekd <- peek tmpPtr - return (Right peekd) - Left msg -> return (Left msg) + do + A.memcpy tmpPtr (plusPtr bufferPtr offset) amountInBuffer + fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr tmpPtr amountInBuffer) + case writeResult of + Right () -> do + peekd <- peek tmpPtr + return (Right peekd) + Left msg -> return (Left msg) diff --git a/library/Ptr/UncheckedShifting.hs b/library/Ptr/UncheckedShifting.hs --- a/library/Ptr/UncheckedShifting.hs +++ b/library/Ptr/UncheckedShifting.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + -- | -- Copyright : (c) 2010 Simon Meier -- @@ -11,16 +12,14 @@ -- -- These functions are undefined when the amount being shifted by is -- greater than the size in bits of a machine Int#.- --- -module Ptr.UncheckedShifting ( - shiftr_w16 - , shiftr_w32 - , shiftr_w64 - , shiftr_w - - , caseWordSize_32_64 - ) where - +module Ptr.UncheckedShifting + ( shiftr_w16, + shiftr_w32, + shiftr_w64, + shiftr_w, + caseWordSize_32_64, + ) +where #if !defined(__HADDOCK__) import GHC.Base @@ -33,9 +32,12 @@ import Data.Word #endif -import Prelude import Foreign +import Prelude +#if MIN_VERSION_base(4,16,0) +import qualified GHC.Exts as Exts +#endif ------------------------------------------------------------------------ -- Unchecked shifts @@ -62,8 +64,20 @@ #endif #if !defined(__HADDOCK__) -shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) +shiftr_w16 (W16# w) (I# i) = W16# ( +#if MIN_VERSION_base(4,16,0) + Exts.uncheckedShiftRLWord16# +#else + uncheckedShiftRL# +#endif + w i) +shiftr_w32 (W32# w) (I# i) = W32# ( +#if MIN_VERSION_base(4,16,0) + Exts.uncheckedShiftRLWord32# +#else + uncheckedShiftRL# +#endif + w i) #if WORD_SIZE_IN_BITS < 64 shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) @@ -77,20 +91,26 @@ shiftr_w64 = shiftR #endif - -- | Select an implementation depending on the bit-size of 'Word's. -- Currently, it produces a runtime failure if the bitsize is different. -- This is detected by the testsuite. {-# INLINE caseWordSize_32_64 #-} -caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's - -> a -- Value to use for 64-bit 'Word's - -> a -caseWordSize_32_64 f32 f64 = +caseWordSize_32_64 :: + -- | Value to use for 32-bit 'Word's + a -> + -- | Value to use for 64-bit 'Word's + a -> + a #if MIN_VERSION_base(4,7,0) +caseWordSize_32_64 f32 f64 = case finiteBitSize (undefined :: Word) of + 32 -> f32 + 64 -> f64 + s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s #else +caseWordSize_32_64 f32 f64 = case bitSize (undefined :: Word) of -#endif 32 -> f32 64 -> f64 s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s +#endif diff --git a/library/Ptr/Util/ByteString.hs b/library/Ptr/Util/ByteString.hs new file mode 100644 --- /dev/null +++ b/library/Ptr/Util/ByteString.hs @@ -0,0 +1,36 @@ +module Ptr.Util.ByteString where + +import Data.ByteString +import qualified Data.ByteString as ByteString +import Data.ByteString.Internal +import Ptr.Prelude hiding (length) +import qualified StrictList + +-- | +-- __Warning:__ +-- +-- It is your responsibility to ensure that the size is correct. +fromReverseStrictList :: Int -> List ByteString -> ByteString +fromReverseStrictList size chunks = + unsafeCreate size (\ptr -> loop (plusPtr ptr size) chunks) + where + loop endPtr = + \case + StrictList.Cons (PS fp off len) tail -> + do + withForeignPtr fp $ \src -> memcpy ptr (plusPtr src off) len + loop ptr tail + where + ptr = plusPtr endPtr (negate len) + StrictList.Nil -> + return () + +fromReverseStrictListWithHead :: ByteString -> Int -> List ByteString -> ByteString +fromReverseStrictListWithHead head sizeInTail tail = + if sizeInTail == 0 + then head + else fromReverseStrictList (sizeInTail + length head) (StrictList.Cons head tail) + +fromPtr :: Int -> Ptr Word8 -> ByteString +fromPtr size src = + unsafeCreate size (\dst -> memcpy dst src size) diff --git a/library/Ptr/Util/Word8Predicates.hs b/library/Ptr/Util/Word8Predicates.hs new file mode 100644 --- /dev/null +++ b/library/Ptr/Util/Word8Predicates.hs @@ -0,0 +1,7 @@ +module Ptr.Util.Word8Predicates where + +import Ptr.Prelude + +asciiUpperLetter :: Word8 -> Bool = \x -> x - 65 <= 25 + +asciiDigit :: Word8 -> Bool = \x -> x - 48 <= 9 diff --git a/ptr.cabal b/ptr.cabal --- a/ptr.cabal +++ b/ptr.cabal @@ -1,7 +1,9 @@ name: ptr -version: 0.16.8.1 +version: 0.16.8.2 category: Ptr, Data -synopsis: Abstractions for operations on pointers +synopsis: Experimental abstractions for operations on pointers +description: + Collection of experimental abstractions over pointer operations. homepage: https://github.com/nikita-volkov/ptr bug-reports: https://github.com/nikita-volkov/ptr/issues author: Nikita Volkov @@ -18,7 +20,7 @@ library hs-source-dirs: library - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 exposed-modules: Ptr.ByteString @@ -29,18 +31,22 @@ Ptr.Poke Ptr.PokeAndPeek Ptr.Poking + Ptr.Read Ptr.Receive other-modules: + Ptr.List Ptr.PokeIO Ptr.Prelude Ptr.Receive.Core Ptr.UncheckedShifting - Ptr.List + Ptr.Util.ByteString + Ptr.Util.Word8Predicates build-depends: - base >=4.9 && <5, + base >=4.11 && <5, bytestring >=0.10 && <0.12, contravariant >=1.3 && <2, profunctors >=5.1 && <6, + strict-list >=0.1.5 && <0.2, text ==1.*, time >=1 && <2, vector >=0.12 && <0.13 @@ -50,9 +56,10 @@ hs-source-dirs: tests main-is: Main.hs ghc-options: -O2 -threaded "-with-rtsopts=-N" - default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples default-language: Haskell2010 build-depends: + cereal >=0.5.8 && <0.6, ptr, QuickCheck >=2.8.1 && <3, quickcheck-instances >=0.3.11 && <0.4, @@ -60,3 +67,17 @@ tasty >=0.12 && <2, tasty-hunit >=0.9 && <0.11, tasty-quickcheck >=0.9 && <0.11 + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -O2 -threaded "-with-rtsopts=-N" + default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples + default-language: Haskell2010 + build-depends: + cereal >=0.5.8 && <0.6, + gauge >=0.2.5 && <0.3, + ptr, + rerebase >=1.10.0.1 && <2, + tostring >=0.2.1.1 && <0.3 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,77 +1,138 @@ module Main where -import Prelude -import Test.Tasty -import Test.Tasty.Runners -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Test.QuickCheck.Instances -import qualified Ptr.Poke as B +import qualified Data.ByteString as D +import qualified Data.ByteString.Char8 as I +import qualified Data.Serialize as J +import qualified Data.Vector.Unboxed as K +import qualified Ptr.ByteString as A +import qualified Ptr.Parse as G import qualified Ptr.Peek as C +import qualified Ptr.Poke as B import qualified Ptr.PokeAndPeek as E -import qualified Ptr.ByteString as A import qualified Ptr.Poking as F -import qualified Ptr.Parse as G -import qualified Data.ByteString as D -import qualified Data.Vector.Unboxed as UnboxedVector - +import qualified Ptr.Read as H +import Test.QuickCheck +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.Tasty.Runners +import Prelude hiding (choose) main = defaultMain $ - testGroup "All tests" - [ - testProperty "ASCII Numbers ByteString Roundtrip" $ \ (numbers :: [Word64]) -> let - expected = foldMap (fromString . show) numbers - actual = A.poking (foldMap F.asciiIntegral numbers) - in expected === actual - , - testProperty "Poke and peek (bytes)" $ \input -> input === fromJust (pokeThenPeek (B.bytes (D.length input)) (C.bytes (D.length input))) input - , - testProperty "Poke and peek (word8)" $ \input -> input === fromJust (pokeThenPeek B.word8 C.word8) input - , - testProperty "Poke and peek (beWord32)" $ \input -> input === fromJust (pokeThenPeek B.beWord32 C.beWord32) input - , - testProperty "Poke and peek (beWord64)" $ \input -> input === fromJust (pokeThenPeek B.beWord64 C.beWord64) input - , - testProperty "PokeAndPeek composition" $ \input -> input === pokeAndPeek ((,) <$> lmap fst E.word8 <*> lmap snd E.beWord32) input - , - testGroup "Poking" - [ - testCase "asciiPaddedAndTrimmedIntegral" $ do - assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 1)) - assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 2001)) - assertEqual "" "000" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 (-1))) - , - testCase "asciiUtcTimeInIso8601" $ do - assertEqual "" "2017-02-01T05:03:58Z" (A.poking (F.asciiUtcTimeInIso8601 (read "2017-02-01 05:03:58Z"))) - , - testCase "fromString" $ do - assertEqual "" "123" (A.poking "123") - , - testCase "intercalateVector" $ do - assertEqual "" "1,2,3,4" (A.poking (F.intercalateVector F.asciiIntegral "," (UnboxedVector.fromList [1 :: Word8, 2, 3, 4]))) - ] - , - parsing - , - testGroup "Regression" [ - testCase "https://github.com/nikita-volkov/hasql-dynamic-statements/issues/2" $ - assertEqual "" "$1000" (A.poking (F.word8 36 <> F.asciiIntegral 1000)) + testGroup + "All tests" + [ testProperty "ASCII Numbers ByteString Roundtrip" $ \(numbers :: [Word64]) -> + let expected = foldMap (fromString . show) numbers + actual = A.poking (foldMap F.asciiIntegral numbers) + in expected === actual, + testProperty "Poke and peek (bytes)" $ \input -> input === fromJust (pokeThenPeek (B.bytes (D.length input)) (C.bytes (D.length input))) input, + testProperty "Poke and peek (word8)" $ \input -> input === fromJust (pokeThenPeek B.word8 C.word8) input, + testProperty "Poke and peek (beWord32)" $ \input -> input === fromJust (pokeThenPeek B.beWord32 C.beWord32) input, + testProperty "Poke and peek (beWord64)" $ \input -> input === fromJust (pokeThenPeek B.beWord64 C.beWord64) input, + testProperty "PokeAndPeek composition" $ \input -> input === pokeAndPeek ((,) <$> lmap fst E.word8 <*> lmap snd E.beWord32) input, + testGroup + "Poking" + [ testCase "asciiPaddedAndTrimmedIntegral" $ do + assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 1)) + assertEqual "" "001" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 2001)) + assertEqual "" "000" (A.poking (F.asciiPaddedAndTrimmedIntegral 3 (-1))), + testCase "asciiUtcTimeInIso8601" $ do + assertEqual "" "2017-02-01T05:03:58Z" (A.poking (F.asciiUtcTimeInIso8601 (read "2017-02-01 05:03:58Z"))), + testCase "fromString" $ do + assertEqual "" "123" (A.poking "123"), + testCase "intercalateVector" $ do + assertEqual "" "1,2,3,4" (A.poking (F.intercalateVector F.asciiIntegral "," (K.fromList [1 :: Word8, 2, 3, 4]))) + ], + parsing, + testGroup + "Regression" + [ testCase "https://github.com/nikita-volkov/hasql-dynamic-statements/issues/2" $ + assertEqual "" "$1000" (A.poking (F.word8 36 <> F.asciiIntegral 1000)) + ], + testGroup "Read" $ + let consumeManyByteStrings :: H.Read a -> [ByteString] -> Maybe a + consumeManyByteStrings read = \case + head : tail -> + H.runOnByteString read head & \case + Left newRead -> consumeManyByteStrings newRead tail + Right (res, rem) -> Just res + _ -> + Nothing + againstByteString :: (Eq a, Show a) => H.Read a -> (ByteString -> a) -> [ByteString] -> Property + againstByteString read fromByteString chunks = + consumeManyByteStrings read chunks & \case + Nothing -> + discard + Just res -> + fromByteString (mconcat chunks) === res + againstCereal :: (Eq a, Show a) => H.Read a -> J.Get a -> [ByteString] -> Property + againstCereal read get chunks = + consumeManyByteStrings read chunks & \res -> + J.runGet get (mconcat chunks) === maybe (Left "Not enough input") Right res + in [ testProperty "byteString" $ \a -> + againstByteString (H.byteString (max 0 a)) (D.take a), + testProperty "skip & byteString" $ \a b -> + againstByteString + (H.skip (max 0 a) *> H.byteString (max 0 b)) + (D.take b . D.drop a), + testProperty "skipWhile" $ \a b -> + againstByteString + (H.skipWhile (< a) *> H.byteString (max 0 b)) + (D.dropWhile (< a) >>> D.take b), + testProperty "byteStringWhile" $ \a -> + againstByteString + (H.byteStringWhile (< a)) + (D.takeWhile (< a)), + testProperty "asciiIntegral" $ + forAll (arbitrary @Int >>= splitRandomly . fromString . (<> " ") . show . abs) $ + againstByteString (H.asciiIntegral) (read . I.unpack), + testProperty "int16InBe" $ + forAll (arbitrary @Int16 >>= splitRandomly . J.runPut . J.putInt16be) $ + againstCereal H.int16InBe J.getInt16be, + testProperty "int32InBe" $ + forAll (arbitrary @Int32 >>= splitRandomly . J.runPut . J.putInt32be) $ + againstCereal H.int32InBe J.getInt32be, + testProperty "int64InBe" $ + forAll (arbitrary @Int64 >>= splitRandomly . J.runPut . J.putInt64be) $ + againstCereal H.int64InBe J.getInt64be, + testProperty "nullTerminatedByteString" $ + againstByteString + (H.nullTerminatedByteString) + (D.takeWhile (/= 0)), + testCase "Pure does not hold on empty input" $ + assertEqual "" (Just ()) (consumeManyByteStrings (pure ()) [""]), + testCase "Monadic composition" $ + do + let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) + consumeManyByteStrings (liftM2 (,) H.int32InBe H.int32InBe) [input] + & assertEqual "" (Just (1, 2)), + testCase "Applicative composition" $ + do + let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) + consumeManyByteStrings (liftA2 (,) H.int32InBe H.int32InBe) [input] + & assertEqual "" (Just (1, 2)), + testProperty "Composition over chunks" $ + let gen = do + (a, b, c) <- arbitrary + splitRandomly (J.runPut (J.putInt16be a <> J.putInt32be b <> J.putInt32be c)) + in forAll gen $ + againstCereal + ((,,) <$> H.int16InBe <*> H.int32InBe <*> H.int32InBe) + ((,,) <$> J.getInt16be <*> J.getInt32be <*> J.getInt32be) + ] ] - ] parsing :: TestTree parsing = - testGroup "Parsing" $ let - assertParsesTo expected input parser = - assertEqual "" (Right expected) (A.parse input (fmap Right parser) (Left . Left) (Left . Right)) - in [ - testCase "bytesWhile" $ assertParsesTo "123" "123456" $ G.bytesWhile (< 52) - , - testCase "bytesWhile on full input" $ assertParsesTo "123456" "123456" $ G.bytesWhile (< 59) - , - testCase "skipWhile on full input" $ assertParsesTo () "123456" $ G.skipWhile (< 59) - ] + testGroup "Parsing" $ + let assertParsesTo expected input parser = + assertEqual "" (Right expected) (A.parse input (fmap Right parser) (Left . Left) (Left . Right)) + in [ testCase "bytesWhile" $ assertParsesTo "123" "123456" $ G.bytesWhile (< 52), + testCase "bytesWhile on full input" $ assertParsesTo "123456" "123456" $ G.bytesWhile (< 59), + testCase "skipWhile on full input" $ assertParsesTo () "123456" $ G.skipWhile (< 59) + ] pokeThenPeek :: B.Poke a -> C.Peek a -> Maybe (a -> a) pokeThenPeek (B.Poke pokeSize pokeIO) (C.Peek peekSize peekIO) = @@ -90,3 +151,15 @@ withForeignPtr fp $ \p -> do poke p input peek p + +splitRandomly :: ByteString -> Gen [ByteString] +splitRandomly = + fmap reverse . buildReverse [] + where + buildReverse chunks input = + if D.null input + then pure chunks + else do + chunkLength <- choose (0, D.length input) + D.splitAt chunkLength input & \(l, r) -> do + buildReverse (l : chunks) r