ptr 0.16.8.1 → 0.16.8.2
raw patch · 21 files changed
+1123/−628 lines, 21 filesdep +cerealdep +gaugedep +strict-listdep ~basedep ~rerebasesetup-changed
Dependencies added: cereal, gauge, strict-list, tostring
Dependency ranges changed: base, rerebase
Files
- Setup.hs +0/−2
- bench/Main.hs +17/−0
- library/Ptr/ByteString.hs +12/−12
- library/Ptr/IO.hs +72/−56
- library/Ptr/List.hs +11/−8
- library/Ptr/Parse.hs +94/−92
- library/Ptr/ParseUnbound.hs +62/−68
- library/Ptr/Peek.hs +115/−43
- library/Ptr/Poke.hs +8/−12
- library/Ptr/PokeAndPeek.hs +27/−31
- library/Ptr/PokeIO.hs +20/−24
- library/Ptr/Poking.hs +66/−65
- library/Ptr/Prelude.hs +27/−45
- library/Ptr/Read.hs +286/−0
- library/Ptr/Receive.hs +18/−23
- library/Ptr/Receive/Core.hs +44/−60
- library/Ptr/UncheckedShifting.hs +39/−19
- library/Ptr/Util/ByteString.hs +36/−0
- library/Ptr/Util/Word8Predicates.hs +7/−0
- ptr.cabal +27/−6
- tests/Main.hs +135/−62
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ bench/Main.hs view
@@ -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)+ ]
library/Ptr/ByteString.hs view
@@ -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
library/Ptr/IO.hs view
@@ -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
library/Ptr/List.hs view
@@ -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
library/Ptr/Parse.hs view
@@ -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 =
library/Ptr/ParseUnbound.hs view
@@ -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 =
library/Ptr/Peek.hs view
@@ -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
library/Ptr/Poke.hs view
@@ -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)
library/Ptr/PokeAndPeek.hs view
@@ -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)
library/Ptr/PokeIO.hs view
@@ -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
library/Ptr/Poking.hs view
@@ -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
library/Ptr/Prelude.hs view
@@ -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, (.))
+ library/Ptr/Read.hs view
@@ -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
library/Ptr/Receive.hs view
@@ -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
library/Ptr/Receive/Core.hs view
@@ -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)
library/Ptr/UncheckedShifting.hs view
@@ -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
+ library/Ptr/Util/ByteString.hs view
@@ -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)
+ library/Ptr/Util/Word8Predicates.hs view
@@ -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
ptr.cabal view
@@ -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 <nikita.y.volkov@mail.ru>@@ -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
tests/Main.hs view
@@ -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