mempack 0.1.2.0 → 0.2.0.0

raw patch · 8 files changed

+450/−94 lines, 8 filesdep +primitivedep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

Dependency ranges changed: vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• bench/Bench.hs +39/−13
• mempack.cabal +10/−5
• src/Data/MemPack.hs +164/−50
• src/Data/MemPack/Buffer.hs +191/−21
• src/Data/MemPack/Error.hs +1/−1
• tests/Test/Common.hs +24/−1
• tests/Test/MemPackSpec.hs +9/−3

@@ -1,5 +1,17 @@ # Changelog for `mempack` +## 0.2.0.0++* Add `mkBuffer`, `bufferHasToBePinned` and `packBuffer`+* Add an offset to the `buffer` function in order to support types that don't use the full+  underlying buffer.+* Add `Buffer` and `MemPack` instances for `PrimArray` and older definition of `ByteArray` from `primitive`.+* Add `MemPack` instances for `Array` from `primitive`.+* Switch `Unpack` monad to be based on the `ST` monad.+* Add `packLiftST` and `unpackLiftST`+* Add `withForeignPtrST` and `withAddrByteStringST`+* Add `Buffer` instances for primitive and storable `Vector`s+ ## 0.1.2.0  * Fix 32-bit support

@@ -9,30 +9,30 @@ import Data.ByteString.Lazy (fromStrict, toStrict) import Data.ByteString.Short (fromShort, toShort) import Data.MemPack+import Data.Primitive.Array (Array) import qualified Data.Serialize as Cereal import qualified Data.Store as Store import qualified Flat as Flat+import GHC.Exts (fromList)  main :: IO () main = do   defaultMain-    [ env (pure [1 :: Int .. 100000]) $ \xs ->+    [ bgroup+        "packedByteCount"+        [ env (pure [1 :: Integer .. 1000000]) $ bench "[Integer]" . whnf packedByteCount+        ]+    , bgroup "[Int]" [env (pure [1 :: Int .. 100000]) packBench]+    , env (pure $ fromList @(Array Int) [1 :: Int .. 100000]) $ \arr ->         bgroup-          "Pack"-          [ bgroup-              "ByteString"-              [ bench "MemPack" $ nf packByteString xs-              , bench "Store" $ nf Store.encode xs-              , bench "Flat" $ nf Flat.flat xs-              , bench "Cereal" $ nf Cereal.encode xs-              , bench "Binary" $ nf (toStrict . Binary.encode) xs-              , bench "Serialise" $ nf (toStrict . Serialise.serialise) xs-              , bench "Avro" $ nf (toStrict . Avro.encodeValue) xs-              ]+          "Array Int"+          [ bench "Pack" $ nf packByteString arr+          , env (pure (packByteString arr)) (bench "Unpack" . nf (unpackError @(Array Int)))+          , bench "RoundTrip" $ nf (unpackError @(Array Int) . packShortByteString) arr           ]     , env (pure [1 :: Int .. 100000]) $ \xs ->         bgroup-          "RoundTrip"+          "RoundTrip List Through"           [ bgroup               "ByteString"               [ bench "MemPack" $ nf (unpackError @[Int] . packByteString) xs@@ -75,4 +75,30 @@                     xs               ]           ]+    ]++packBench ::+  ( MemPack a+  , Store.Store a+  , Flat.Flat a+  , Cereal.Serialize a+  , Binary.Binary a+  , Serialise.Serialise a+  , Avro.HasAvroSchema a+  , Avro.ToAvro a+  ) =>+  a -> Benchmark+packBench xs =+  bgroup+    "Pack"+    [ bgroup+        "ByteString"+        [ bench "MemPack" $ nf packByteString xs+        , bench "Store" $ nf Store.encode xs+        , bench "Flat" $ nf Flat.flat xs+        , bench "Cereal" $ nf Cereal.encode xs+        , bench "Binary" $ nf (toStrict . Binary.encode) xs+        , bench "Serialise" $ nf (toStrict . Serialise.serialise) xs+        , bench "Avro" $ nf (toStrict . Avro.encodeValue) xs+        ]     ]

@@ -1,5 +1,5 @@ name:                mempack-version:             0.1.2.0+version:             0.2.0.0 synopsis:            Short description description:         Please see the README on GitHub at <https://github.com/lehins/mempack#readme> homepage:            https://github.com/lehins/mempack@@ -7,7 +7,7 @@ license-file:        LICENSE author:              Alexey Kuleshevich maintainer:          alexey@kuleshevi.ch-copyright:           2024 Alexey Kuleshevich+copyright:           2024-2025 Alexey Kuleshevich category:            Algorithms build-type:          Simple extra-source-files:  README.md@@ -21,8 +21,8 @@                    , GHC == 9.4.8                    , GHC == 9.6.7                    , GHC == 9.8.4-                   , GHC == 9.10.1-                   , GHC == 9.12.1+                   , GHC == 9.10.3+                   , GHC == 9.12.2  library   hs-source-dirs:      src@@ -31,11 +31,13 @@                      , Data.MemPack.Error    other-modules:-  build-depends:       base >= 4.12 && < 5+  build-depends:       base >=4.12 && <5                      , bytestring                      , FailT+                     , primitive >=0.6.4                      , mtl                      , text+                     , vector >=0.10.12   if !impl(ghc >= 9.4)     build-depends:     data-array-byte   if !impl(ghc >= 9.0)@@ -59,9 +61,11 @@                     , hspec                     , mempack                     , mtl+                    , primitive                     , QuickCheck                     , random >=1.2.1                     , text+                    , vector   if !impl(ghc >= 9.4)     build-depends:     data-array-byte @@ -90,6 +94,7 @@                      , criterion                      , flat                      , mempack+                     , primitive                      , serialise                      , store                      , vector

@@ -11,12 +11,13 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-}  -- | -- Module      : Data.MemPack--- Copyright   : (c) Alexey Kuleshevich 2024+-- Copyright   : (c) Alexey Kuleshevich 2024-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch> -- Stability   : experimental@@ -28,6 +29,7 @@    -- * Packing   pack,+  packBuffer,   packByteString,   packShortByteString, @@ -54,6 +56,8 @@   unpackByteArrayLen,   packByteStringM,   unpackByteStringM,+  packLiftST,+  unpackLiftST,    -- * Helper packers   VarLen (..),@@ -81,7 +85,7 @@ import qualified Control.Monad.Fail as F import Control.Monad.Reader (MonadReader (..), lift) import Control.Monad.State.Strict (MonadState (..), StateT (..), execStateT)-import Control.Monad.Trans.Fail (Fail, FailT (..), errorFail, failT, runFailAgg)+import Control.Monad.Trans.Fail (Fail, FailT (..), errorFail, failT, runFailAgg, runFailAggT) import Data.Array.Byte (ByteArray (..), MutableByteArray (..)) import Data.Bifunctor (first) import Data.Bits (Bits (..), FiniteBits (..))@@ -91,11 +95,14 @@ import Data.ByteString.Short (ShortByteString) import Data.Char (ord) import Data.Complex (Complex (..))+import qualified Data.Foldable as F (foldl') import Data.List (intercalate) import Data.MemPack.Buffer import Data.MemPack.Error+import Data.Primitive.Array (Array (..), newArray, sizeofArray, unsafeFreezeArray, writeArray)+import Data.Primitive.PrimArray (PrimArray (..), sizeofPrimArray)+import Data.Primitive.Types (Prim (sizeOf#)) import Data.Ratio-import Data.Semigroup (Sum (..)) #if MIN_VERSION_text(2,0,0) import qualified Data.Text.Array as T #endif@@ -120,9 +127,12 @@ #else #error "Only integer-gmp is supported for now for older compilers" #endif-#if !(MIN_VERSION_base(4,13,0))+#if !MIN_VERSION_base(4,13,0) import Prelude (fail) #endif+#if !MIN_VERSION_primitive(0,8,0)+import qualified Data.Primitive.ByteArray as Prim (ByteArray(..))+#endif  -- | Monad that is used for serializing data into a `MutableByteArray`. It is based on -- `StateT` that tracks the current index into the `MutableByteArray` where next write is@@ -166,14 +176,14 @@ -- `StateT` that tracks the current index into the @`Buffer` a@, from where the next read -- suppose to happen. Unpacking can `F.fail` with `F.MonadFail` instance or with -- `failUnpack` that provides a more type safe way of failing using `Error` interface.-newtype Unpack b a = Unpack-  { runUnpack :: b -> StateT Int (Fail SomeError) a+newtype Unpack s b a = Unpack+  { runUnpack :: b -> StateT Int (FailT SomeError (ST s)) a   } -instance Functor (Unpack s) where+instance Functor (Unpack s b) where   fmap f (Unpack p) = Unpack $ \buf -> fmap f (p buf)   {-# INLINE fmap #-}-instance Applicative (Unpack b) where+instance Applicative (Unpack s b) where   pure = Unpack . const . pure   {-# INLINE pure #-}   Unpack a1 <*> Unpack a2 =@@ -182,23 +192,23 @@   Unpack a1 *> Unpack a2 =     Unpack $ \buf -> a1 buf *> a2 buf   {-# INLINE (*>) #-}-instance Monad (Unpack b) where+instance Monad (Unpack s b) where   Unpack m1 >>= p =     Unpack $ \buf -> m1 buf >>= \res -> runUnpack (p res) buf   {-# INLINE (>>=) #-} #if !(MIN_VERSION_base(4,13,0))   fail = Unpack . const . F.fail #endif-instance F.MonadFail (Unpack b) where+instance F.MonadFail (Unpack s b) where   fail = Unpack . const . F.fail-instance MonadReader b (Unpack b) where+instance MonadReader b (Unpack s b) where   ask = Unpack pure   {-# INLINE ask #-}   local f (Unpack p) = Unpack (p . f)   {-# INLINE local #-}   reader f = Unpack (pure . f)   {-# INLINE reader #-}-instance MonadState Int (Unpack b) where+instance MonadState Int (Unpack s b) where   get = Unpack $ const get   {-# INLINE get #-}   put = Unpack . const . put@@ -206,7 +216,7 @@   state = Unpack . const . state   {-# INLINE state #-} -instance Alternative (Unpack b) where+instance Alternative (Unpack s b) where   empty = Unpack $ \_ -> lift empty   {-# INLINE empty #-}   Unpack r1 <|> Unpack r2 =@@ -218,7 +228,7 @@   {-# INLINE (<|>) #-}  -- | Failing unpacking with an `Error`.-failUnpack :: Error e => e -> Unpack b a+failUnpack :: Error e => e -> Unpack s b a failUnpack e = Unpack $ \_ -> lift $ failT (toSomeError e)  -- | Efficient serialization interface that operates directly on memory buffers.@@ -241,11 +251,13 @@   packM :: a -> Pack s ()    -- | Read binary representation of the type directly from the buffer, which can be-  -- accessed with `ask` when necessary. Direct reads from the buffer should be preceded-  -- with advancing the buffer offset with `MonadState` by the number of bytes that will-  -- be consumed from the buffer and making sure that no reads outside of the buffer can-  -- happen. Violation of these rules will lead to segfaults.-  unpackM :: Buffer b => Unpack b a+  -- accessed with `ask` when necessary.+  --+  -- /Warning/ - Direct reads from the buffer should be preceded with advancing the buffer offset+  -- within `MonadState` by the exact number of bytes that gets consumed from that buffer.+  --+  -- __⚠__ - Violation of the above rule will lead to segfaults.+  unpackM :: Buffer b => Unpack s b a  instance MemPack () where   packedByteCount _ = 0@@ -320,7 +332,7 @@     let c =           buffer             buf-            (\ba# -> C# (indexWord8ArrayAsWideChar# ba# i#))+            (\ba# off# -> C# (indexWord8ArrayAsWideChar# ba# (i# +# off#)))             (\addr# -> C# (indexWideCharOffAddr# (addr# `plusAddr#` i#) 0#))         ordc :: Word32         ordc = fromIntegral (ord c)@@ -344,7 +356,7 @@     pure $!       buffer         buf-        (\ba# -> F# (indexWord8ArrayAsFloat# ba# i#))+        (\ba# off# -> F# (indexWord8ArrayAsFloat# ba# (i# +# off#)))         (\addr# -> F# (indexFloatOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -362,7 +374,7 @@     pure $!       buffer         buf-        (\ba# -> D# (indexWord8ArrayAsDouble# ba# i#))+        (\ba# off# -> D# (indexWord8ArrayAsDouble# ba# (i# +# off#)))         (\addr# -> D# (indexDoubleOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -381,7 +393,7 @@     pure $!       buffer         buf-        (\ba# -> Ptr (indexWord8ArrayAsAddr# ba# i#))+        (\ba# off# -> Ptr (indexWord8ArrayAsAddr# ba# (i# +# off#)))         (\addr# -> Ptr (indexAddrOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -400,7 +412,7 @@     pure $!       buffer         buf-        (\ba# -> StablePtr (indexWord8ArrayAsStablePtr# ba# i#))+        (\ba# off# -> StablePtr (indexWord8ArrayAsStablePtr# ba# (i# +# off#)))         (\addr# -> StablePtr (indexStablePtrOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -418,7 +430,7 @@     pure $!       buffer         buf-        (\ba# -> I# (indexWord8ArrayAsInt# ba# i#))+        (\ba# off# -> I# (indexWord8ArrayAsInt# ba# (i# +# off#)))         (\addr# -> I# (indexIntOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -436,7 +448,7 @@     pure $!       buffer         buf-        (\ba# -> I8# (indexInt8Array# ba# i#))+        (\ba# off# -> I8# (indexInt8Array# ba# (i# +# off#)))         (\addr# -> I8# (indexInt8OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -454,7 +466,7 @@     pure $!       buffer         buf-        (\ba# -> I16# (indexWord8ArrayAsInt16# ba# i#))+        (\ba# off# -> I16# (indexWord8ArrayAsInt16# ba# (i# +# off#)))         (\addr# -> I16# (indexInt16OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -472,7 +484,7 @@     pure $!       buffer         buf-        (\ba# -> I32# (indexWord8ArrayAsInt32# ba# i#))+        (\ba# off# -> I32# (indexWord8ArrayAsInt32# ba# (i# +# off#)))         (\addr# -> I32# (indexInt32OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -490,7 +502,7 @@     pure $!       buffer         buf-        (\ba# -> I64# (indexWord8ArrayAsInt64# ba# i#))+        (\ba# off# -> I64# (indexWord8ArrayAsInt64# ba# (i# +# off#)))         (\addr# -> I64# (indexInt64OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -508,7 +520,7 @@     pure $!       buffer         buf-        (\ba# -> W# (indexWord8ArrayAsWord# ba# i#))+        (\ba# off# -> W# (indexWord8ArrayAsWord# ba# (i# +# off#)))         (\addr# -> W# (indexWordOffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -526,7 +538,7 @@     pure $!       buffer         buf-        (\ba# -> W8# (indexWord8Array# ba# i#))+        (\ba# off# -> W8# (indexWord8Array# ba# (i# +# off#)))         (\addr# -> W8# (indexWord8OffAddr# addr# i#))   {-# INLINE unpackM #-} @@ -544,7 +556,7 @@     pure $!       buffer         buf-        (\ba# -> W16# (indexWord8ArrayAsWord16# ba# i#))+        (\ba# off# -> W16# (indexWord8ArrayAsWord16# ba# (i# +# off#)))         (\addr# -> W16# (indexWord16OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -562,7 +574,7 @@     pure $!       buffer         buf-        (\ba# -> W32# (indexWord8ArrayAsWord32# ba# i#))+        (\ba# off# -> W32# (indexWord8ArrayAsWord32# ba# (i# +# off#)))         (\addr# -> W32# (indexWord32OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -580,7 +592,7 @@     pure $!       buffer         buf-        (\ba# -> W64# (indexWord8ArrayAsWord64# ba# i#))+        (\ba# off# -> W64# (indexWord8ArrayAsWord64# ba# (i# +# off#)))         (\addr# -> W64# (indexWord64OffAddr# (addr# `plusAddr#` i#) 0#))   {-# INLINE unpackM #-} @@ -881,7 +893,12 @@  instance MemPack a => MemPack [a] where   typeName = "[" ++ typeName @a ++ "]"-  packedByteCount es = packedByteCount (Length (length es)) + getSum (foldMap (Sum . packedByteCount) es)+  packedByteCount es =+    let go [] (# listLen#, elemsLen# #) = packedByteCount (Length (I# listLen#)) + (I# elemsLen#)+        go (x : xs) (# listLen#, elemsLen# #) =+          let !(I# bc#) = packedByteCount x+           in go xs (# 1# +# listLen#, bc# +# elemsLen# #)+     in go es (# 0#, 0# #)   {-# INLINE packedByteCount #-}   packM as = do     packM (Length (length as))@@ -892,6 +909,27 @@     replicateTailM n unpackM   {-# INLINE unpackM #-} +instance MemPack a => MemPack (Array a) where+  typeName = "(Array " ++ typeName @a ++ ")"+  packedByteCount arr =+    packedByteCount (Length (sizeofArray arr))+      + F.foldl' (\acc e -> acc + packedByteCount e) 0 arr+  {-# INLINE packedByteCount #-}+  packM as = do+    packM (Length (length as))+    mapM_ packM as+  {-# INLINE packM #-}+  unpackM = do+    Length n <- unpackM+    marr <- unpackLiftST (newArray n (error "Uninitialized"))+    let fill !i = when (i < n) $ do+          e <- unpackM+          unpackLiftST (writeArray marr i e)+          fill (i + 1)+    fill 0+    unpackLiftST (unsafeFreezeArray marr)+  {-# INLINE unpackM #-}+ -- | Tail recursive version of `replicateM` replicateTailM :: Monad m => Int -> m a -> m [a] replicateTailM n f = go n []@@ -916,6 +954,38 @@   unpackM = unpackByteArray False   {-# INLINE unpackM #-} +instance (Typeable a, Prim a) => MemPack (PrimArray a) where+  packedByteCount pa =+    let len = I# (sizeOf# (undefined :: a)) * sizeofPrimArray pa+     in packedByteCount (Length len) + len+  {-# INLINE packedByteCount #-}+  packM pa@(PrimArray ba#) = do+    let !len@(I# len#) = I# (sizeOf# (undefined :: a)) * sizeofPrimArray pa+    packM (Length len)+    I# curPos# <- state $ \i -> (i, i + len)+    MutableByteArray mba# <- ask+    lift_# (copyByteArray# ba# 0# mba# curPos# len#)+  {-# INLINE packM #-}+  unpackM = (\(ByteArray ba#) -> PrimArray ba#) <$> unpackByteArray False+  {-# INLINE unpackM #-}++#if !MIN_VERSION_primitive(0,8,0)+instance MemPack Prim.ByteArray where+  packedByteCount ba =+    let len = bufferByteCount ba+     in packedByteCount (Length len) + len+  {-# INLINE packedByteCount #-}+  packM ba@(Prim.ByteArray ba#) = do+    let !len@(I# len#) = bufferByteCount ba+    packM (Length len)+    I# curPos# <- state $ \i -> (i, i + len)+    MutableByteArray mba# <- ask+    lift_# (copyByteArray# ba# 0# mba# curPos# len#)+  {-# INLINE packM #-}+  unpackM = (\(ByteArray ba#) -> Prim.ByteArray ba#) <$> unpackByteArray False+  {-# INLINE unpackM #-}+#endif+ instance MemPack ShortByteString where   packedByteCount ba =     let len = bufferByteCount ba@@ -983,7 +1053,9 @@     MutableByteArray mba# <- ask     lift_# (copyByteArray# ba# offset# mba# curPos# len#) #else-  -- FIXME: This is very inefficient and shall be fixed in the next major version+  -- FIXME: This is very inefficient and hopefully will be fixed at some point.  It requires some+  -- clever change to the MemPack interface in order to allow memoization between `packedByteCount`+  -- and `packM`   packedByteCount = packedByteCount . T.encodeUtf8   packM = packM . T.encodeUtf8 #endif@@ -998,7 +1070,7 @@ {- FOURMOLU_ENABLE -}  -- | This is the implementation of `unpackM` for `ByteArray`, `ByteString` and `ShortByteString`-unpackByteArray :: Buffer b => Bool -> Unpack b ByteArray+unpackByteArray :: Buffer b => Bool -> Unpack s b ByteArray unpackByteArray isPinned = unpackByteArrayLen isPinned . unLength =<< unpackM {-# INLINE unpackByteArray #-} @@ -1007,7 +1079,7 @@ -- Similar to `unpackByteArray`, except it does not unpack a length. -- -- @since 0.1.1-unpackByteArrayLen :: Buffer b => Bool -> Int -> Unpack b ByteArray+unpackByteArrayLen :: Buffer b => Bool -> Int -> Unpack s b ByteArray unpackByteArrayLen isPinned len@(I# len#) = do   I# curPos# <- guardAdvanceUnpack len   buf <- ask@@ -1015,7 +1087,7 @@     mba@(MutableByteArray mba#) <- newMutableByteArray isPinned len     buffer       buf-      (\ba# -> st_ (copyByteArray# ba# curPos# mba# 0# len#))+      (\ba# off# -> st_ (copyByteArray# ba# (curPos# +# off#) mba# 0# len#))       (\addr# -> st_ (copyAddrToByteArray# (addr# `plusAddr#` curPos#) mba# 0# len#))     freezeMutableByteArray mba {-# INLINE unpackByteArrayLen #-}@@ -1032,7 +1104,7 @@ -- | Increment the offset counter of `Unpack` monad by the supplied number of -- bytes. Returns the original offset or fails with `RanOutOfBytesError` whenever there is -- not enough bytes in the `Buffer`.-guardAdvanceUnpack :: Buffer b => Int -> Unpack b Int+guardAdvanceUnpack :: Buffer b => Int -> Unpack s b Int guardAdvanceUnpack n@(I# n#) = do   buf <- ask   let !len = bufferByteCount buf@@ -1044,7 +1116,7 @@       _ -> (failOutOfBytes i len n, i) {-# INLINE guardAdvanceUnpack #-} -failOutOfBytes :: Int -> Int -> Int -> Unpack b a+failOutOfBytes :: Int -> Int -> Int -> Unpack s b a failOutOfBytes i len n =   failUnpack $     toSomeError $@@ -1071,6 +1143,27 @@ packByteString = pinnedByteArrayToByteString . packByteArray True {-# INLINE packByteString #-} +-- | Serialize a type into any `Buffer`+--+-- prop> pack xs == packBuffer xs+--+-- prop> packByteString xs == packBuffer xs+--+-- ====__Examples__+--+-- >>> :set -XTypeApplications+-- >>> import qualified Data.Vector.Primitive as VP+-- >>> import Data.Word (Word8)+-- >>> unpack @[Int] $ packBuffer @[Int] @(VP.Vector Word8) [1,2,3,4,5]+-- Right [1,2,3,4,5]+--+-- @since 0.2.0+packBuffer :: forall a b. (MemPack a, Buffer b, HasCallStack) => a -> b+packBuffer a =+  case packByteArray (bufferHasToBePinned @b) a of+    ByteArray ba -> mkBuffer ba+{-# INLINE packBuffer #-}+ -- | Serialize a type into an unpinned `ShortByteString` packShortByteString :: forall a. (MemPack a, HasCallStack) => a -> ShortByteString packShortByteString = byteArrayToShortByteString . pack@@ -1160,7 +1253,7 @@ packByteStringM bs = do   let !len@(I# len#) = bufferByteCount bs   I# curPos# <- state $ \i -> (i, i + len)-  Pack $ \(MutableByteArray mba#) -> lift $ withPtrByteStringST bs $ \(Ptr addr#) ->+  Pack $ \(MutableByteArray mba#) -> lift $ withAddrByteStringST bs $ \addr# ->     st_ (copyAddrToByteArray# addr# mba# curPos# len#) {-# INLINE packByteStringM #-} @@ -1171,19 +1264,26 @@   Buffer b =>   -- | number of bytes to unpack   Int ->-  Unpack b ByteString+  Unpack s b ByteString unpackByteStringM len = pinnedByteArrayToByteString <$> unpackByteArrayLen True len {-# INLINE unpackByteStringM #-}  -- | Unpack a memory `Buffer` into a type using its `MemPack` instance. Besides the -- unpacked type it also returns an index into a buffer where unpacked has stopped. unpackLeftOver :: forall a b. (MemPack a, Buffer b, HasCallStack) => b -> Fail SomeError (a, Int)-unpackLeftOver b = do+unpackLeftOver b = FailT $ pure $ runST $ runFailAggT $ unpackLeftOverST b+{-# INLINE unpackLeftOver #-}++-- | Unpack a memory `Buffer` into a type using its `MemPack` instance. Besides the+-- unpacked type it also returns an index into a buffer where unpacked has stopped.+unpackLeftOverST ::+  forall a b s. (MemPack a, Buffer b, HasCallStack) => b -> FailT SomeError (ST s) (a, Int)+unpackLeftOverST b = do   let len = bufferByteCount b   res@(_, consumedBytes) <- runStateT (runUnpack unpackM b) 0   when (consumedBytes > len) $ errorLeftOver (typeName @a) consumedBytes len   pure res-{-# INLINEABLE unpackLeftOver #-}+{-# INLINEABLE unpackLeftOverST #-}  -- | This is a critical error, therefore we are not gracefully failing this unpacking errorLeftOver :: HasCallStack => String -> Int -> Int -> a@@ -1348,13 +1448,13 @@ unpack7BitVarLen ::   (Num a, Bits a, Buffer b) =>   -- | Continuation that will be invoked if MSB is set-  (Word8 -> a -> Unpack b a) ->+  (Word8 -> a -> Unpack s b a) ->   -- | Will be set either to 0 initially or to the very first unmodified byte, which is   -- guaranteed to have the first bit set.   Word8 ->   -- | Accumulator   a ->-  Unpack b a+  Unpack s b a unpack7BitVarLen cont firstByte !acc = do   b8 :: Word8 <- unpackM   if b8 `testBit` 7@@ -1364,12 +1464,12 @@ {-# INLINE unpack7BitVarLen #-}  unpack7BitVarLenLast ::-  forall t b.+  forall t b s.   (Num t, Bits t, MemPack t, Buffer b) =>   Word8 ->   Word8 ->   t ->-  Unpack b t+  Unpack s b t unpack7BitVarLenLast mask firstByte acc = do   res <- unpack7BitVarLen (\_ _ -> F.fail "Too many bytes.") firstByte acc   -- Only while decoding the last 7bits we check if there was too many@@ -1440,7 +1540,7 @@ packedTagByteCount = SIZEOF_WORD8 {-# INLINE packedTagByteCount #-} -unpackTagM :: Buffer b => Unpack b Tag+unpackTagM :: Buffer b => Unpack s b Tag unpackTagM = Tag <$> unpackM {-# INLINE unpackTagM #-} @@ -1458,3 +1558,17 @@ st_ :: (State# s -> State# s) -> ST s () st_ f = ST $ \s# -> (# f s#, () #) {-# INLINE st_ #-}++-- | Lift an `ST` action into the `Pack` monad+--+-- @since 0.2.0+packLiftST :: ST s a -> Pack s a+packLiftST st = Pack (\_ -> StateT (\i -> (,i) <$> st))+{-# INLINE packLiftST #-}++-- | Lift an `ST` action into the `Unpack` monad+--+-- @since 0.2.0+unpackLiftST :: ST s a -> Unpack s b a+unpackLiftST st = Unpack (\_ -> StateT (\i -> FailT (Right . (,i) <$> st)))+{-# INLINE unpackLiftST #-}

@@ -1,95 +1,265 @@-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}  -- | -- Module      : Data.MemPack.Buffer--- Copyright   : (c) Alexey Kuleshevich 2024+-- Copyright   : (c) Alexey Kuleshevich 2024-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch> -- Stability   : experimental -- Portability : non-portable-module Data.MemPack.Buffer where+module Data.MemPack.Buffer (+  Buffer (..),+  newMutableByteArray,+  freezeMutableByteArray,+  withPtrByteStringST,+  withAddrByteStringST,+  withForeignPtrST,+  pinnedByteArrayToByteString,+  pinnedByteArrayToForeignPtr,+  byteArrayToShortByteString,+  byteArrayFromShortByteString,+)+where  import Data.Array.Byte import qualified Data.ByteString as BS-import qualified Data.ByteString.Short.Internal as SBS import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Short.Internal as SBS+import Data.Primitive.PrimArray (PrimArray (..))+import Data.Word (Word8) import GHC.Exts-import GHC.ST import GHC.ForeignPtr+import GHC.ST+#if !MIN_VERSION_primitive(0,8,0)+import qualified Data.Primitive.ByteArray as Prim (ByteArray(..))+#endif+import qualified Data.Vector.Primitive as VP (Vector (..))+import qualified Data.Vector.Storable as VS (+  Vector,+  length,+  unsafeFromForeignPtr0,+  unsafeToForeignPtr0,+ )  -- | Immutable memory buffer class Buffer b where+  -- | Number of accessible bytes in the buffer.   bufferByteCount :: b -> Int -  buffer :: b -> (ByteArray# -> a) -> (Addr# -> a) -> a+  -- | Use one of the two suppplied functions to access memory of the buffer:+  buffer ::+    -- | A type that contains the actual buffer that will be accessed+    b ->+    -- | In case when a buffer is backed by a `ByteArray#` it will be accessed as such with an+    -- offset from the beginning of the ByteArray+    (ByteArray# -> Int# -> a) ->+    -- | In case when a buffer is backed by a pointer or a pinned `ByteArray#` it can be accessed as+    -- an `Addr#`. No offset is necessary here, since same affect can be achieved with pointer+    -- arithmetic.+    (Addr# -> a) ->+    a +  mkBuffer :: ByteArray# -> b++  bufferHasToBePinned :: Bool+ instance Buffer ByteArray where   bufferByteCount (ByteArray ba#) = I# (sizeofByteArray# ba#)   {-# INLINE bufferByteCount #-}+  buffer (ByteArray ba#) f _ = f ba# 0#+  {-# INLINE buffer #-}+  mkBuffer ba# = ByteArray ba#+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = False -  buffer (ByteArray ba#) f _ = f ba#+#if !MIN_VERSION_primitive(0,8,0)+instance Buffer Prim.ByteArray where+  bufferByteCount (Prim.ByteArray ba#) = I# (sizeofByteArray# ba#)+  {-# INLINE bufferByteCount #-}+  buffer (Prim.ByteArray ba#) f _ = f ba# 0#   {-# INLINE buffer #-}+  mkBuffer ba# = Prim.ByteArray ba#+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = False+#endif  instance Buffer SBS.ShortByteString where   bufferByteCount = SBS.length   {-# INLINE bufferByteCount #-}--  buffer (SBS.SBS ba#) f _ = f ba#+  buffer (SBS.SBS ba#) f _ = f ba# 0#   {-# INLINE buffer #-}+  mkBuffer ba# = SBS.SBS ba#+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = False  instance Buffer BS.ByteString where   bufferByteCount = BS.length   {-# INLINE bufferByteCount #-}+  buffer bs _f g =+    runST $ withAddrByteStringST bs $ \addr# -> pure (g addr#)+  {-# INLINE buffer #-}+  mkBuffer ba# = pinnedByteArrayToByteString (ByteArray ba#)+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = True -  buffer bs _ f =-    runST $ withPtrByteStringST bs $ \(Ptr addr#) -> pure $! f addr#+instance Buffer (PrimArray Word8) where+  bufferByteCount (PrimArray ba#) = I# (sizeofByteArray# ba#)+  {-# INLINE bufferByteCount #-}+  buffer (PrimArray ba#) f _ = f ba# 0#   {-# INLINE buffer #-}+  mkBuffer ba# = PrimArray ba#+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = False +instance Buffer (VP.Vector Word8) where+  bufferByteCount (VP.Vector _ len _) = len+  {-# INLINE bufferByteCount #-}+  buffer (VP.Vector (I# off#) _ ba) f = buffer ba (\ba# _ -> f ba# off#)+  {-# INLINE buffer #-}+  mkBuffer ba# =+    let ba = mkBuffer ba#+     in VP.Vector 0 (bufferByteCount ba) ba+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = False -newMutableByteArray :: Bool -> Int -> ST s (MutableByteArray s)+instance Buffer (VS.Vector Word8) where+  bufferByteCount = VS.length+  {-# INLINE bufferByteCount #-}+  buffer v _f g =+    runST $ withForeignPtrST (fst $ VS.unsafeToForeignPtr0 v) $ \addr# -> pure (g addr#)+  {-# INLINE buffer #-}+  mkBuffer ba# =+    VS.unsafeFromForeignPtr0 (pinnedByteArrayToForeignPtr ba#) (I# (sizeofByteArray# ba#))+  {-# INLINE mkBuffer #-}+  bufferHasToBePinned = True++-- | Allocate a new uninitialized `MutableByteArray`.+--+-- * __Warning__ - Memory allocated might contain random garbage and must be fully overwritten.+--+-- __⚠__ - Violation of the above rule could lead non-determinism and breakage of referential+-- transparency.+--+-- @since 0.1.0+newMutableByteArray ::+  -- | Should the mutable array be allocated as pinned or not+  Bool ->+  -- | Size of the mutable array in number of bytes.+  Int ->+  ST s (MutableByteArray s) newMutableByteArray isPinned (I# len#) =   ST $ \s# -> case (if isPinned then newPinnedByteArray# else newByteArray#) len# s# of     (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #) {-# INLINE newMutableByteArray #-} +-- | /O(1)/ - Cast a `MutableByteArray` to an immutable `ByteArray` without copy.+--+-- * __Warning__ - Source mutable array must not be mutated, after this action.+--+-- __⚠__ - Violation of the above rule could potentially lead to corrupt memory and segfaults.+--+-- @since 0.1.0 freezeMutableByteArray :: MutableByteArray d -> ST d ByteArray freezeMutableByteArray (MutableByteArray mba#) =   ST $ \s# -> case unsafeFreezeByteArray# mba# s# of     (# s'#, ba# #) -> (# s'#, ByteArray ba# #) --- | It is ok to use ByteString withing ST, as long as underlying pointer is never mutated--- or returned from the supplied action.+-- | Run ST action on the underlying `Ptr` that points to the beginning of the `ByteString`+-- buffer. It is ok to use ByteString withing ST, as long as underlying pointer is never mutated or+-- returned from the supplied action.+--+-- * __Warning__ - It is important for the supplied action to not produce bottom, i.e. runtime+-- exceptions or infinite loops are not allowed within its body.+--+-- __⚠__ - Violation of the above rule could potentially lead to corrupt memory and segfaults.+--+-- @since 0.1.0 withPtrByteStringST :: BS.ByteString -> (Ptr a -> ST s b) -> ST s b+withPtrByteStringST bs f = withAddrByteStringST bs $ \addr# -> f (Ptr addr#)+{-# INLINE withPtrByteStringST #-}++-- | Same as `withPtrByteStringST`, except the supplied action expects an `Addr#` instead of a+-- `Ptr`.+--+-- __⚠__ - Violation of the rule from `withPtrByteStringST` could potentially lead to corrupt memory+-- and segfaults.+--+-- @since 0.2.0+withAddrByteStringST :: BS.ByteString -> (Addr# -> ST s b) -> ST s b #if MIN_VERSION_bytestring(0,11,0)-withPtrByteStringST (BS.BS (ForeignPtr addr# ptrContents) _) f = do+withAddrByteStringST (BS.BS fp _) = withForeignPtrST fp #else-withPtrByteStringST (BS.PS (ForeignPtr addr0# ptrContents) (I# offset#) _) f = do-  let !addr# = addr0# `plusAddr#` offset#+withAddrByteStringST (BS.PS fp offset _) = withForeignPtrST (fp `plusForeignPtr` offset) #endif-  !r <- f (Ptr addr#)-  -- It is safe to use `touch#` within ST, so `unsafeCoerce#` is OK+{-# INLINE withAddrByteStringST #-}++-- | Run an `ST` action on the underlying `Ptr` that points to the beginning of the `ByteString`+-- buffer. It is ok to use ByteString withing ST, as long as underlying pointer is never mutated or+-- returned from the supplied action.+--+-- * __Warning__ - It is important for the memory that backs the underlying `ForeignPtr` to not be+-- mutated outside of the `ST` monad that this action operates in, which is only allowed if it was+-- allocated in this execution of the `ST` monad.+--+-- * __Warning__ - It is important for the memory that backs the underlying `ForeignPtr` to not be+-- mutated at all if `ForeignPtr` was not allocated within the `ST` monad that this action operates+-- in.+--+-- * __Warning__ - It is important for the supplied action to not produce bottom, i.e. runtime+-- exceptions or infinite loops are not allowed within its body.+--+-- __⚠__ - Violation of the above rules could potentially lead to corrupt memory and segfaults.+--+-- @since 0.2.0+withForeignPtrST :: ForeignPtr a -> (Addr# -> ST s b) -> ST s b+withForeignPtrST (ForeignPtr addr# ptrContents) f = do+  !r <- f addr#+  -- It is safe to use `touch#` within ST, so using `unsafeCoerce#` here is totally OK   ST $ \s# -> (# unsafeCoerce# (touch# ptrContents (unsafeCoerce# s#)), () #)   pure r-{-# INLINE withPtrByteStringST #-}+{-# INLINE withForeignPtrST #-} +-- | /O(1)/ - Convert a pinned `ByteArray` to `BS.ByteString`.+--+-- * __Warning__ - There is no check that source `ByteArray` was allocated as pinned, so user of this+-- function must guarantee this invariant.+--+-- __⚠__ - Violation of the above rules could potentially lead to corrupt memory and segfaults.+--+-- @since 0.1.0 pinnedByteArrayToByteString :: ByteArray -> BS.ByteString pinnedByteArrayToByteString (ByteArray ba#) =   BS.PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#)) {-# INLINE pinnedByteArrayToByteString #-} +-- | /O(1)/ - Convert a pinned `ByteArray#` to `ForeignPtr`.+--+-- * __Warning__ - There is no check that source `ByteArray#` was allocated as pinned, so user of this+-- function must guarantee this invariant.+--+-- __⚠__ - Violation of the above rules could potentially lead to corrupt memory and segfaults.+--+-- @since 0.1.0 pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a pinnedByteArrayToForeignPtr ba# =   ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#)) {-# INLINE pinnedByteArrayToForeignPtr #-} -+-- | /O(1)/ - Convert `ByteArray` to `SBS.ShortByteString`+--+-- @since 0.1.0 byteArrayToShortByteString :: ByteArray -> SBS.ShortByteString byteArrayToShortByteString (ByteArray ba#) = SBS.SBS ba# {-# INLINE byteArrayToShortByteString #-} +-- | /O(1)/ - Inverse of `byteArrayToShortByteString`. Convert `SBS.ShortByteString` to  `ByteArray`+--+-- @since 0.1.0 byteArrayFromShortByteString :: SBS.ShortByteString -> ByteArray byteArrayFromShortByteString (SBS.SBS ba#) = ByteArray ba# {-# INLINE byteArrayFromShortByteString #-}

@@ -6,7 +6,7 @@  -- | -- Module      : Data.MemPack.Error--- Copyright   : (c) Alexey Kuleshevich 2024+-- Copyright   : (c) Alexey Kuleshevich 2024-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch> -- Stability   : experimental

@@ -9,10 +9,17 @@  import Data.Array.Byte (ByteArray (..)) import Data.ByteString (ByteString)-import Data.ByteString.Short.Internal as SBS (ShortByteString (..)) import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Short.Internal as SBS (ShortByteString (..)) import Data.MemPack.Buffer (byteArrayFromShortByteString)+import Data.Primitive.Array (Array)+import Data.Primitive.PrimArray (PrimArray (..), primArrayFromList)+import Data.Primitive.Types (Prim) import qualified Data.Text as T+import qualified Data.Vector.Generic as VG (fromList)+import qualified Data.Vector.Primitive as VP (Vector (..), drop)+import qualified Data.Vector.Storable as VS (Storable, Vector, drop)+import GHC.Exts (fromList) import System.Random.Stateful import Test.Hspec as X import Test.Hspec.QuickCheck as X@@ -50,6 +57,22 @@  instance Arbitrary T.Text where   arbitrary = T.pack <$> arbitrary++instance (Prim a, Arbitrary a) => Arbitrary (PrimArray a) where+  arbitrary = primArrayFromList <$> arbitrary++instance Arbitrary a => Arbitrary (Array a) where+  arbitrary = fromList <$> arbitrary++instance (Prim a, Arbitrary a) => Arbitrary (VP.Vector a) where+  arbitrary = do+    v <- VG.fromList <$> arbitrary+    frequency [(5, pure v), (5, flip VP.drop v . getNonNegative <$> arbitrary)]++instance (VS.Storable a, Arbitrary a) => Arbitrary (VS.Vector a) where+  arbitrary = do+    v <- VG.fromList <$> arbitrary+    frequency [(5, pure v), (5, flip VS.drop v . getNonNegative <$> arbitrary)]  qcByteArray :: Int -> Gen ByteArray qcByteArray n = byteArrayFromShortByteString <$> qcShortByteString n

@@ -18,8 +18,8 @@ import Data.Array.Byte (ByteArray) import Data.Bits import Data.ByteString (ByteString)-import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Short (ShortByteString) import Data.Complex import Data.Either (isLeft) import Data.Function (fix)@@ -27,8 +27,11 @@ import Data.MemPack import Data.MemPack.Buffer import Data.MemPack.Error+import Data.Primitive.Array (Array)+import Data.Primitive.PrimArray (PrimArray (..)) import Data.Ratio import Data.Text (Text)+import qualified Data.Vector.Primitive as VP (Vector (..)) import Data.Word import Foreign.Ptr (IntPtr (..), Ptr, intPtrToPtr) import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr)@@ -145,7 +148,7 @@   unpackM =     (IntCase <$> unpackCase 0) <|> (Word16Case <$> unpackCase 1)     where-      unpackCase :: (Buffer b, MemPack a) => Tag -> Unpack b a+      unpackCase :: (Buffer b, MemPack a) => Tag -> Unpack s b a       unpackCase t = do         t' <- unpackM         unless (t == t') $ F.fail "Tag mismatch"@@ -196,6 +199,8 @@       it "ByteArray" $ failOnEmpty (mempty :: ByteArray)       it "ByteString" $ failOnEmpty (mempty :: ByteString)       it "ShortByteString" $ failOnEmpty (mempty :: ShortByteString)+      it "PrimArray" $ failOnEmpty (mempty :: PrimArray Word8)+      it "VP.Vector" $ failOnEmpty (mempty :: VP.Vector Word8)     prop "Fail on too much" $ expectNotFullyConsumed @a  spec :: Spec@@ -240,7 +245,8 @@   memPackSpec @ByteArray   memPackSpec @ByteString   memPackSpec @BSL.ByteString-  memPackSpec @ByteArray+  memPackSpec @(PrimArray Char)+  memPackSpec @(Array Integer)   memPackSpec @Text   memPackSpec @Backtrack   prop "Out of bound char" $ forAll (choose (0x110000, maxBound :: Word32)) $ \w32 ->