mempack (empty) → 0.1.0.0
raw patch · 12 files changed
+2039/−0 lines, 12 filesdep +FailTdep +QuickCheckdep +basesetup-changed
Dependencies added: FailT, QuickCheck, base, binary, bytestring, cereal, criterion, data-array-byte, flat, hspec, integer-gmp, mempack, mtl, random, serialise, store, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +22/−0
- Setup.hs +4/−0
- bench/Bench.hs +74/−0
- mempack.cabal +96/−0
- src/Data/MemPack.hs +1293/−0
- src/Data/MemPack/Buffer.hs +95/−0
- src/Data/MemPack/Error.hs +106/−0
- tests/Main.hs +25/−0
- tests/Test/Common.hs +46/−0
- tests/Test/MemPackSpec.hs +243/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for `mempack`++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexey Kuleshevich (c) 2024++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Alexey Kuleshevich nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,22 @@+# mempack++## Overview++Extremely efficient serialization library that works on pinned and unpinned memory alike.++## Status++| Github Actions | Coveralls | Hackage | Nightly | LTS |+|:--------------:|:---------:|:-------:|:-------:|:---:|+| [![Build Status][GA-badge]][GA-link] | [![Coverage Status][Coveralls-badge]][Coveralls-link] | [![Hackage][Hackage-badge]][Hackage-link] | [![Nightly][Nightly-badge]][Nightly-link] | [![LTS][LTS-badge]][LTS-link]++[GA-badge]: https://github.com/lehins/mempack/workflows/CI/badge.svg+[GA-link]: https://github.com/lehins/mempack/actions+[Coveralls-badge]: https://coveralls.io/repos/github/lehins/mempack/badge.svg?branch=master+[Coveralls-link]: https://coveralls.io/github/lehins/mempack?branch=master+[Hackage-badge]: https://img.shields.io/hackage/v/mempack.svg+[Hackage-link]: https://hackage.haskell.org/package/mempack+[Nightly-badge]: https://www.stackage.org/package/mempack/badge/nightly+[Nightly-link]: https://www.stackage.org/nightly/package/mempack+[LTS-badge]: https://www.stackage.org/package/mempack/badge/lts+[LTS-link]: https://www.stackage.org/lts/package/mempack
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Codec.Serialise as Serialise+import Criterion.Main+import qualified Data.Binary as Binary+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.ByteString.Short (fromShort, toShort)+import Data.MemPack+import qualified Data.Serialize as Cereal+import qualified Data.Store as Store+import qualified Flat as Flat++main :: IO ()+main = do+ defaultMain+ [ env (pure [1 :: Int .. 100000]) $ \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+ ]+ ]+ , env (pure [1 :: Int .. 100000]) $ \xs ->+ bgroup+ "RoundTrip"+ [ bgroup+ "ByteString"+ [ bench "MemPack" $ nf (unpackError @[Int] . packByteString) xs+ , bench "Store" $ nf (Store.decodeEx @[Int] . Store.encode) xs+ , bench "Flat" $ nf (either (error . show) id . Flat.unflat @[Int] . Flat.flat) xs+ , bench "Cereal" $ nf (either (error . show) id . Cereal.decode @[Int] . Cereal.encode) xs+ , bench "Binary" $ nf (Binary.decode @[Int] . fromStrict . toStrict . Binary.encode) xs+ , bench "Serialise" $+ nf (Serialise.deserialiseOrFail @[Int] . fromStrict . toStrict . Serialise.serialise) xs+ ]+ , bgroup+ "ShortByteString"+ [ bench "MemPack" $ nf (unpackError @[Int] . packShortByteString) xs+ , bench "Store" $ nf (Store.decodeEx @[Int] . fromShort . toShort . Store.encode) xs+ , bench "Flat" $+ nf (either (error . show) id . Flat.unflat @[Int] . fromShort . toShort . Flat.flat) xs+ , bench "Cereal" $+ nf (either (error . show) id . Cereal.decode @[Int] . fromShort . toShort . Cereal.encode) xs+ , bench "Binary" $+ nf+ ( Binary.decode @[Int]+ . fromStrict+ . fromShort+ . toShort+ . toStrict+ . Binary.encode+ )+ xs+ , bench "Serialise" $+ nf+ ( Serialise.deserialiseOrFail @[Int]+ . fromStrict+ . fromShort+ . toShort+ . toStrict+ . Serialise.serialise+ )+ xs+ ]+ ]+ ]
+ mempack.cabal view
@@ -0,0 +1,96 @@+name: mempack+version: 0.1.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+license: BSD3+license-file: LICENSE+author: Alexey Kuleshevich+maintainer: alexey@kuleshevi.ch+copyright: 2024 Alexey Kuleshevich+category: Algorithms+build-type: Simple+extra-source-files: README.md+ , CHANGELOG.md+cabal-version: 1.18+tested-with: GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.6+ , GHC == 9.8.2+ , GHC == 9.10.1++library+ hs-source-dirs: src+ exposed-modules: Data.MemPack+ , Data.MemPack.Buffer+ , Data.MemPack.Error++ other-modules:+ build-depends: base >= 4.12 && < 5+ , bytestring+ , FailT+ , mtl+ , text+ if !impl(ghc >= 9.4)+ build-depends: data-array-byte+ if !impl(ghc >= 9.0)+ build-depends: integer-gmp++ default-language: Haskell2010+ ghc-options: -Wall+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ other-modules: Test.Common+ , Test.MemPackSpec+ build-depends: base+ , bytestring+ , FailT+ , hspec+ , mempack+ , mtl+ , QuickCheck+ , random >=1.2.1+ if !impl(ghc >= 9.4)+ build-depends: data-array-byte++ default-language: Haskell2010+ ghc-options: -Wall+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints+ -fno-warn-orphans+ -threaded+ -with-rtsopts=-N2++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Bench.hs+ ghc-options: -Wall+ -threaded+ -O2+ -with-rtsopts=-N+ build-depends: base+ , binary+ , bytestring+ , cereal+ , criterion+ , flat+ , mempack+ , serialise+ , store+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/lehins/mempack
+ src/Data/MemPack.hs view
@@ -0,0 +1,1293 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module : Data.MemPack+-- Copyright : (c) Alexey Kuleshevich 2024+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+module Data.MemPack (+ Pack (..),+ Unpack (..),+ MemPack (..),++ -- * Packing+ pack,+ packByteArray,+ packByteString,+ packShortByteString,+ packMutableByteArray,++ -- ** Helpers+ packIncrement,+ guardAdvanceUnpack,++ -- * Unpacking+ unpack,+ unpackFail,+ unpackMonadFail,+ unpackError,+ unpackLeftOver,++ -- ** Helpers+ failUnpack,+ unpackByteArray,++ -- * Helper packers+ VarLen (..),+ Length (..),+ Tag (..),+ packTagM,+ unpackTagM,+ unknownTagM,+ packedTagByteCount,++ -- * Internal utilities+ replicateTailM,+ lift_#,+ st_,++ -- * Re-exports for @GeneralizedNewtypeDeriving@+ StateT (..),+ FailT (..),+) where++#include "MachDeps.h"++import Control.Applicative (Alternative (..))+import Control.Monad (join, unless, when)+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 Data.Array.Byte (ByteArray (..), MutableByteArray (..))+import Data.Bifunctor (first)+import Data.Bits (Bits (..), FiniteBits (..))+import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString)+import Data.Char (ord)+import Data.Complex (Complex (..))+import Data.List (intercalate)+import Data.MemPack.Buffer+import Data.MemPack.Error+import Data.Ratio+import Data.Semigroup (Sum (..))+import Data.Typeable+import GHC.Exts+import GHC.Int+import GHC.ST (ST (..), runST)+import GHC.Stable (StablePtr (..))+import GHC.Stack (HasCallStack)+import GHC.Word+import Numeric (showHex)+import Prelude hiding (fail)+#if __GLASGOW_HASKELL__ >= 900+import GHC.Num.Integer (Integer (..), integerCheck)+import GHC.Num.Natural (Natural (..), naturalCheck)+#elif defined(MIN_VERSION_integer_gmp)+import GHC.Integer.GMP.Internals (Integer (..), BigNat(BN#), isValidInteger#)+import GHC.Natural (Natural (..), isValidNatural)+#else+#error "Only integer-gmp is supported for now for older compilers"+#endif+#if !(MIN_VERSION_base(4,13,0))+import Prelude (fail)+#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+-- expected to happen.+newtype Pack s a = Pack+ { runPack :: MutableByteArray s -> StateT Int (ST s) a+ }++instance Functor (Pack s) where+ fmap f (Pack p) = Pack $ \buf -> fmap f (p buf)+ {-# INLINE fmap #-}+instance Applicative (Pack s) where+ pure = Pack . const . pure+ {-# INLINE pure #-}+ Pack a1 <*> Pack a2 =+ Pack $ \buf -> a1 buf <*> a2 buf+ {-# INLINE (<*>) #-}+ Pack a1 *> Pack a2 =+ Pack $ \buf -> a1 buf *> a2 buf+ {-# INLINE (*>) #-}+instance Monad (Pack s) where+ Pack m1 >>= p =+ Pack $ \buf -> m1 buf >>= \res -> runPack (p res) buf+ {-# INLINE (>>=) #-}+instance MonadReader (MutableByteArray s) (Pack s) where+ ask = Pack pure+ {-# INLINE ask #-}+ local f (Pack p) = Pack (p . f)+ {-# INLINE local #-}+ reader f = Pack (pure . f)+ {-# INLINE reader #-}+instance MonadState Int (Pack s) where+ get = Pack $ const get+ {-# INLINE get #-}+ put = Pack . const . put+ {-# INLINE put #-}+ state = Pack . const . state+ {-# INLINE state #-}++-- | Monad that is used for deserializing data from a memory `Buffer`. It is based on+-- `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+ }++instance Functor (Unpack s) where+ fmap f (Unpack p) = Unpack $ \buf -> fmap f (p buf)+ {-# INLINE fmap #-}+instance Applicative (Unpack b) where+ pure = Unpack . const . pure+ {-# INLINE pure #-}+ Unpack a1 <*> Unpack a2 =+ Unpack $ \buf -> a1 buf <*> a2 buf+ {-# INLINE (<*>) #-}+ Unpack a1 *> Unpack a2 =+ Unpack $ \buf -> a1 buf *> a2 buf+ {-# INLINE (*>) #-}+instance Monad (Unpack 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+ fail = Unpack . const . F.fail+instance MonadReader b (Unpack 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+ get = Unpack $ const get+ {-# INLINE get #-}+ put = Unpack . const . put+ {-# INLINE put #-}+ state = Unpack . const . state+ {-# INLINE state #-}++instance Alternative (Unpack b) where+ empty = Unpack $ \_ -> lift empty+ {-# INLINE empty #-}+ Unpack r1 <|> Unpack r2 =+ Unpack $ \buf ->+ case r1 buf of+ StateT m1 ->+ case r2 buf of+ StateT m2 -> StateT $ \s -> m1 s <|> m2 s+ {-# INLINE (<|>) #-}++-- | Failing unpacking with an `Error`.+failUnpack :: Error e => e -> Unpack b a+failUnpack e = Unpack $ \_ -> lift $ failT (toSomeError e)++-- | Efficient serialization interface that operates directly on memory buffers.+class MemPack a where+ -- | Name of the type that is being deserialized for error reporting. Default+ -- implementation relies on `Typeable`.+ typeName :: String+ default typeName :: Typeable a => String+ typeName = show (typeRep (Proxy @a))++ -- | Report the exact size in number of bytes that packed version of this type will+ -- occupy. It is very important to get this right, otherwise `packM` will result in a+ -- runtime exception. Another words this is the expected property that it should hold:+ --+ -- prop> packedByteCount a == bufferByteCount (pack a)+ packedByteCount :: a -> Int++ -- | Write binary representation of a type into the `MutableByteArray` which can be+ -- accessed with `ask`, whenever direct operations on it are necessary.+ 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++instance MemPack () where+ packedByteCount _ = 0+ {-# INLINE packedByteCount #-}+ packM _ = pure ()+ {-# INLINE packM #-}+ unpackM = pure ()+ {-# INLINE unpackM #-}++instance MemPack Bool where+ packedByteCount _ = packedTagByteCount+ {-# INLINE packedByteCount #-}+ packM x = packTagM $ if x then 1 else 0+ {-# INLINE packM #-}+ unpackM =+ unpackTagM >>= \case+ 0 -> pure False+ 1 -> pure True+ n -> F.fail $ "Invalid value detected for Bool: " ++ show n+ {-# INLINE unpackM #-}++instance MemPack a => MemPack (Maybe a) where+ typeName = "Maybe " ++ typeName @a+ packedByteCount = \case+ Nothing -> packedTagByteCount+ Just a -> packedTagByteCount + packedByteCount a+ {-# INLINE packedByteCount #-}+ packM = \case+ Nothing -> packTagM 0+ Just a -> packTagM 1 >> packM a+ {-# INLINE packM #-}+ unpackM =+ unpackTagM >>= \case+ 0 -> pure Nothing+ 1 -> Just <$> unpackM+ n -> unknownTagM @(Maybe a) n+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b) => MemPack (Either a b) where+ typeName = "Either " ++ typeName @a ++ " " ++ typeName @b+ packedByteCount = \case+ Left a -> packedTagByteCount + packedByteCount a+ Right b -> packedTagByteCount + packedByteCount b+ {-# INLINE packedByteCount #-}+ packM = \case+ Left a -> packTagM 0 >> packM a+ Right b -> packTagM 1 >> packM b+ {-# INLINE packM #-}+ unpackM =+ unpackTagM >>= \case+ 0 -> Left <$> unpackM+ 1 -> Right <$> unpackM+ n -> unknownTagM @(Either a b) n+ {-# INLINE unpackM #-}++instance MemPack Char where+ packedByteCount _ = SIZEOF_HSCHAR+ {-# INLINE packedByteCount #-}+ packM a@(C# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsWideChar# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_HSCHAR+ buf <- ask+ let c =+ buffer+ buf+ (\ba# -> C# (indexWord8ArrayAsWideChar# ba# i#))+ (\addr# -> C# (indexWideCharOffAddr# (addr# `plusAddr#` i#) 0#))+ when (ord c > 0x10FFFF) $+ F.fail $+ "Out of bounds Char was detected: '\\x" ++ showHex (fromEnum c) "'"+ pure c+ {-# INLINE unpackM #-}++instance MemPack Float where+ packedByteCount _ = SIZEOF_FLOAT+ {-# INLINE packedByteCount #-}+ packM a@(F# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsFloat# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_FLOAT+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> F# (indexWord8ArrayAsFloat# ba# i#))+ (\addr# -> F# (indexFloatOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Double where+ packedByteCount _ = SIZEOF_DOUBLE+ {-# INLINE packedByteCount #-}+ packM a@(D# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsDouble# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_DOUBLE+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> D# (indexWord8ArrayAsDouble# ba# i#))+ (\addr# -> D# (indexDoubleOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack (Ptr a) where+ typeName = "Ptr"+ packedByteCount _ = SIZEOF_HSPTR+ {-# INLINE packedByteCount #-}+ packM a@(Ptr a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsAddr# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_HSPTR+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> Ptr (indexWord8ArrayAsAddr# ba# i#))+ (\addr# -> Ptr (indexAddrOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack (StablePtr a) where+ typeName = "StablePtr"+ packedByteCount _ = SIZEOF_HSSTABLEPTR+ {-# INLINE packedByteCount #-}+ packM a@(StablePtr a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsStablePtr# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_HSSTABLEPTR+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> StablePtr (indexWord8ArrayAsStablePtr# ba# i#))+ (\addr# -> StablePtr (indexStablePtrOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Int where+ packedByteCount _ = SIZEOF_HSINT+ {-# INLINE packedByteCount #-}+ packM a@(I# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsInt# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_HSINT+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> I# (indexWord8ArrayAsInt# ba# i#))+ (\addr# -> I# (indexIntOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Int8 where+ packedByteCount _ = SIZEOF_INT8+ {-# INLINE packedByteCount #-}+ packM a@(I8# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeInt8Array# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_INT8+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> I8# (indexInt8Array# ba# i#))+ (\addr# -> I8# (indexInt8OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Int16 where+ packedByteCount _ = SIZEOF_INT16+ {-# INLINE packedByteCount #-}+ packM a@(I16# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsInt16# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ buf <- ask+ I# i# <- guardAdvanceUnpack SIZEOF_INT16+ pure $!+ buffer+ buf+ (\ba# -> I16# (indexWord8ArrayAsInt16# ba# i#))+ (\addr# -> I16# (indexInt16OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Int32 where+ packedByteCount _ = SIZEOF_INT32+ {-# INLINE packedByteCount #-}+ packM a@(I32# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsInt32# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ buf <- ask+ I# i# <- guardAdvanceUnpack SIZEOF_INT32+ pure $!+ buffer+ buf+ (\ba# -> I32# (indexWord8ArrayAsInt32# ba# i#))+ (\addr# -> I32# (indexInt32OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Int64 where+ packedByteCount _ = SIZEOF_INT64+ {-# INLINE packedByteCount #-}+ packM a@(I64# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsInt64# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ buf <- ask+ I# i# <- guardAdvanceUnpack SIZEOF_INT64+ pure $!+ buffer+ buf+ (\ba# -> I64# (indexWord8ArrayAsInt64# ba# i#))+ (\addr# -> I64# (indexInt64OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Word where+ packedByteCount _ = SIZEOF_HSWORD+ {-# INLINE packedByteCount #-}+ packM a@(W# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsWord# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_HSWORD+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> W# (indexWord8ArrayAsWord# ba# i#))+ (\addr# -> W# (indexWordOffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Word8 where+ packedByteCount _ = SIZEOF_WORD8+ {-# INLINE packedByteCount #-}+ packM a@(W8# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8Array# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_WORD8+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> W8# (indexWord8Array# ba# i#))+ (\addr# -> W8# (indexWord8OffAddr# addr# i#))+ {-# INLINE unpackM #-}++instance MemPack Word16 where+ packedByteCount _ = SIZEOF_WORD16+ {-# INLINE packedByteCount #-}+ packM a@(W16# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsWord16# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ buf <- ask+ I# i# <- guardAdvanceUnpack SIZEOF_WORD16+ pure $!+ buffer+ buf+ (\ba# -> W16# (indexWord8ArrayAsWord16# ba# i#))+ (\addr# -> W16# (indexWord16OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Word32 where+ packedByteCount _ = SIZEOF_WORD32+ {-# INLINE packedByteCount #-}+ packM a@(W32# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsWord32# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_WORD32+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> W32# (indexWord8ArrayAsWord32# ba# i#))+ (\addr# -> W32# (indexWord32OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++instance MemPack Word64 where+ packedByteCount _ = SIZEOF_WORD64+ {-# INLINE packedByteCount #-}+ packM a@(W64# a#) = do+ MutableByteArray mba# <- ask+ I# i# <- packIncrement a+ lift_# (writeWord8ArrayAsWord64# mba# i# a#)+ {-# INLINE packM #-}+ unpackM = do+ I# i# <- guardAdvanceUnpack SIZEOF_WORD64+ buf <- ask+ pure $!+ buffer+ buf+ (\ba# -> W64# (indexWord8ArrayAsWord64# ba# i#))+ (\addr# -> W64# (indexWord64OffAddr# (addr# `plusAddr#` i#) 0#))+ {-# INLINE unpackM #-}++#if __GLASGOW_HASKELL__ >= 900+instance MemPack Integer where+ packedByteCount =+ (+ packedTagByteCount) . \case+ IS i# -> packedByteCount (I# i#)+ IP ba# -> packedByteCount (ByteArray ba#)+ IN ba# -> packedByteCount (ByteArray ba#)+ {-# INLINE packedByteCount #-}+ packM = \case+ IS i# -> packTagM 0 >> packM (I# i#)+ IP ba# -> packTagM 1 >> packM (ByteArray ba#)+ IN ba# -> packTagM 2 >> packM (ByteArray ba#)+ {-# INLINE packM #-}+ unpackM = do+ i <-+ unpackTagM >>= \case+ 0 -> do+ I# i# <- unpackM+ pure $ IS i#+ 1 -> do+ ByteArray ba# <- unpackM+ pure $ IP ba#+ 2 -> do+ ByteArray ba# <- unpackM+ pure $ IN ba#+ t -> unknownTagM @Integer t+ unless (integerCheck i) $ F.fail $ "Invalid Integer decoded " ++ showInteger i+ pure i+ where+ showInteger = \case+ IS i# -> "IS " ++ show (I# i#)+ IP ba# -> "IP " ++ show (ByteArray ba#)+ IN ba# -> "IN " ++ show (ByteArray ba#)+ {-# INLINE unpackM #-}++instance MemPack Natural where+ packedByteCount =+ (+ packedTagByteCount) . \case+ NS w# -> packedByteCount (W# w#)+ NB ba# -> packedByteCount (ByteArray ba#)+ {-# INLINE packedByteCount #-}+ packM = \case+ NS w# -> packTagM 0 >> packM (W# w#)+ NB ba# -> packTagM 1 >> packM (ByteArray ba#)+ {-# INLINE packM #-}+ unpackM = do+ n <-+ unpackTagM >>= \case+ 0 -> do+ W# w# <- unpackM+ pure $ NS w#+ 1 -> do+ ByteArray ba# <- unpackM+ pure $ NB ba#+ t -> unknownTagM @Natural t+ unless (naturalCheck n) $ F.fail $ "Invalid Natural decoded " ++ showNatural n+ pure n+ where+ showNatural = \case+ NS w# -> "NS " ++ show (W# w#)+ NB ba# -> "NB " ++ show (ByteArray ba#)+ {-# INLINE unpackM #-}++#elif defined(MIN_VERSION_integer_gmp)++instance MemPack Integer where+ packedByteCount =+ (+ packedTagByteCount) . \case+ S# i# -> packedByteCount (I# i#)+ Jp# (BN# ba#) -> packedByteCount (ByteArray ba#)+ Jn# (BN# ba#) -> packedByteCount (ByteArray ba#)+ {-# INLINE packedByteCount #-}+ packM = \case+ S# i# -> packTagM 0 >> packM (I# i#)+ Jp# (BN# ba#) -> packTagM 1 >> packM (ByteArray ba#)+ Jn# (BN# ba#) -> packTagM 2 >> packM (ByteArray ba#)+ {-# INLINE packM #-}+ unpackM = do+ i <-+ unpackTagM >>= \case+ 0 -> do+ I# i# <- unpackM+ pure $ S# i#+ 1 -> do+ ByteArray ba# <- unpackM+ pure $ Jp# (BN# ba#)+ 2 -> do+ ByteArray ba# <- unpackM+ pure $ Jn# (BN# ba#)+ t -> unknownTagM @Integer t+ unless (isTrue# (isValidInteger# i)) $ F.fail $ "Invalid Integer decoded " ++ showInteger i+ pure i+ where+ showInteger = \case+ S# i# -> "S# " ++ show (I# i#)+ Jp# (BN# ba#) -> "Jp# " ++ show (ByteArray ba#)+ Jn# (BN# ba#) -> "Jn# " ++ show (ByteArray ba#)+ {-# INLINE unpackM #-}++instance MemPack Natural where+ packedByteCount =+ (+ packedTagByteCount) . \case+ NatS# w# -> packedByteCount (W# w#)+ NatJ# (BN# ba#) -> packedByteCount (ByteArray ba#)+ {-# INLINE packedByteCount #-}+ packM = \case+ NatS# w# -> packTagM 0 >> packM (W# w#)+ NatJ# (BN# ba#) -> packTagM 1 >> packM (ByteArray ba#)+ {-# INLINE packM #-}+ unpackM = do+ n <-+ unpackTagM >>= \case+ 0 -> do+ W# w# <- unpackM+ pure $ NatS# w#+ 1 -> do+ ByteArray ba# <- unpackM+ pure $ NatJ# (BN# ba#)+ t -> unknownTagM @Natural t+ unless (isValidNatural n) $ F.fail $ "Invalid Natural decoded " ++ showNatural n+ pure n+ where+ showNatural = \case+ NatS# w# -> "NatS# " ++ show (W# w#)+ NatJ# (BN# ba#) -> "NatJ# " ++ show (ByteArray ba#)+ {-# INLINE unpackM #-}++#endif++instance MemPack a => MemPack (Complex a) where+ typeName = "Complex " ++ typeName @a+ packedByteCount (a :+ b) = packedByteCount a + packedByteCount b+ {-# INLINE packedByteCount #-}+ packM (a :+ b) = packM a >> packM b+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ pure (a :+ b)+ {-# INLINE unpackM #-}++instance (MemPack a, Integral a) => MemPack (Ratio a) where+ typeName = "Ratio " ++ typeName @a+ packedByteCount r = packedByteCount (numerator r) + packedByteCount (denominator r)+ {-# INLINE packedByteCount #-}+ packM r = packM (numerator r) >> packM (denominator r)+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ when (b == 0) $ F.fail $ "Zero denominator was detected when unpacking " ++ typeName @(Ratio a)+ pure (a % b)+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b) => MemPack (a, b) where+ typeName = "(" ++ typeName @a ++ "," ++ typeName @b ++ ")"+ packedByteCount (a, b) = packedByteCount a + packedByteCount b+ {-# INLINE packedByteCount #-}+ packM (a, b) = packM a >> packM b+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ pure (a, b)+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b, MemPack c) => MemPack (a, b, c) where+ typeName = "(" ++ typeName @a ++ "," ++ typeName @b ++ "," ++ typeName @c ++ ")"+ packedByteCount (a, b, c) = packedByteCount a + packedByteCount b + packedByteCount c+ {-# INLINE packedByteCount #-}+ packM (a, b, c) = packM a >> packM b >> packM c+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ !c <- unpackM+ pure (a, b, c)+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b, MemPack c, MemPack d) => MemPack (a, b, c, d) where+ typeName = "(" ++ typeName @a ++ "," ++ typeName @b ++ "," ++ typeName @c ++ "," ++ typeName @d ++ ")"+ packedByteCount (a, b, c, d) = packedByteCount a + packedByteCount b + packedByteCount c + packedByteCount d+ {-# INLINE packedByteCount #-}+ packM (a, b, c, d) =+ packM a >> packM b >> packM c >> packM d+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ !c <- unpackM+ !d <- unpackM+ pure (a, b, c, d)+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b, MemPack c, MemPack d, MemPack e) => MemPack (a, b, c, d, e) where+ typeName =+ "("+ ++ intercalate+ ","+ [ typeName @a+ , typeName @b+ , typeName @c+ , typeName @d+ , typeName @e+ ]+ ++ ")"+ packedByteCount (a, b, c, d, e) =+ packedByteCount a + packedByteCount b + packedByteCount c + packedByteCount d + packedByteCount e+ {-# INLINE packedByteCount #-}+ packM (a, b, c, d, e) =+ packM a >> packM b >> packM c >> packM d >> packM e+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ !c <- unpackM+ !d <- unpackM+ !e <- unpackM+ pure (a, b, c, d, e)+ {-# INLINE unpackM #-}++instance (MemPack a, MemPack b, MemPack c, MemPack d, MemPack e, MemPack f) => MemPack (a, b, c, d, e, f) where+ typeName =+ "("+ ++ intercalate+ ","+ [ typeName @a+ , typeName @b+ , typeName @c+ , typeName @d+ , typeName @e+ , typeName @f+ ]+ ++ ")"+ packedByteCount (a, b, c, d, e, f) =+ packedByteCount a+ + packedByteCount b+ + packedByteCount c+ + packedByteCount d+ + packedByteCount e+ + packedByteCount f+ {-# INLINE packedByteCount #-}+ packM (a, b, c, d, e, f) =+ packM a >> packM b >> packM c >> packM d >> packM e >> packM f+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ !c <- unpackM+ !d <- unpackM+ !e <- unpackM+ !f <- unpackM+ pure (a, b, c, d, e, f)+ {-# INLINE unpackM #-}++instance+ (MemPack a, MemPack b, MemPack c, MemPack d, MemPack e, MemPack f, MemPack g) =>+ MemPack (a, b, c, d, e, f, g)+ where+ typeName =+ "("+ ++ intercalate+ ","+ [ typeName @a+ , typeName @b+ , typeName @c+ , typeName @d+ , typeName @e+ , typeName @f+ , typeName @g+ ]+ ++ ")"+ packedByteCount (a, b, c, d, e, f, g) =+ packedByteCount a+ + packedByteCount b+ + packedByteCount c+ + packedByteCount d+ + packedByteCount e+ + packedByteCount f+ + packedByteCount g+ {-# INLINE packedByteCount #-}+ packM (a, b, c, d, e, f, g) =+ packM a >> packM b >> packM c >> packM d >> packM e >> packM f >> packM g+ {-# INLINE packM #-}+ unpackM = do+ !a <- unpackM+ !b <- unpackM+ !c <- unpackM+ !d <- unpackM+ !e <- unpackM+ !f <- unpackM+ !g <- unpackM+ pure (a, b, c, d, e, f, g)+ {-# INLINE unpackM #-}++instance MemPack a => MemPack [a] where+ typeName = "[" ++ typeName @a ++ "]"+ packedByteCount es = packedByteCount (Length (length es)) + getSum (foldMap (Sum . packedByteCount) es)+ {-# INLINE packedByteCount #-}+ packM as = do+ packM (Length (length as))+ mapM_ packM as+ {-# INLINE packM #-}+ unpackM = do+ Length n <- unpackM+ replicateTailM n unpackM+ {-# INLINE unpackM #-}++-- | Tail recursive version of `replicateM`+replicateTailM :: Monad m => Int -> m a -> m [a]+replicateTailM n f = go n []+ where+ go i !acc+ | i <= 0 = pure $ reverse acc+ | otherwise = f >>= \x -> go (i - 1) (x : acc)+{-# INLINE replicateTailM #-}++instance MemPack ByteArray where+ packedByteCount ba =+ let len = bufferByteCount ba+ in packedByteCount (Length len) + len+ {-# INLINE packedByteCount #-}+ packM ba@(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 = unpackByteArray False+ {-# INLINE unpackM #-}++instance MemPack ShortByteString where+ packedByteCount ba =+ let len = bufferByteCount ba+ in packedByteCount (Length len) + len+ {-# INLINE packedByteCount #-}+ packM = packM . byteArrayFromShortByteString+ {-# INLINE packM #-}+ unpackM = byteArrayToShortByteString <$> unpackByteArray False+ {-# INLINE unpackM #-}++instance MemPack ByteString where+ packedByteCount ba =+ let len = bufferByteCount ba+ in packedByteCount (Length len) + len+ {-# INLINE packedByteCount #-}+ packM bs = do+ let !len@(I# len#) = bufferByteCount bs+ packM (Length len)+ I# curPos# <- state $ \i -> (i, i + len)+ Pack $ \(MutableByteArray mba#) -> lift $ withPtrByteStringST bs $ \(Ptr addr#) ->+ st_ (copyAddrToByteArray# addr# mba# curPos# len#)+ {-# INLINE packM #-}+ unpackM = pinnedByteArrayToByteString <$> unpackByteArray True+ {-# INLINE unpackM #-}++-- | This is the implementation of `unpackM` for `ByteArray` and `ByteString`+unpackByteArray :: Buffer b => Bool -> Unpack b ByteArray+unpackByteArray isPinned = do+ Length len@(I# len#) <- unpackM+ I# curPos# <- guardAdvanceUnpack len+ buf <- ask+ pure $! runST $ do+ mba@(MutableByteArray mba#) <- newMutableByteArray isPinned len+ buffer+ buf+ (\ba# -> st_ (copyByteArray# ba# curPos# mba# 0# len#))+ (\addr# -> st_ (copyAddrToByteArray# (addr# `plusAddr#` curPos#) mba# 0# len#))+ freezeMutableByteArray mba+{-# INLINE unpackByteArray #-}++-- | Increment the offset counter of `Pack` monad by then number of `packedByteCount` and+-- return the starting offset.+packIncrement :: MemPack a => a -> Pack s Int+packIncrement a =+ state $ \i ->+ let !n = i + packedByteCount a+ in (i, n)+{-# INLINE packIncrement #-}++-- | 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 n@(I# n#) = do+ buf <- ask+ let len = bufferByteCount buf+ failOutOfBytes i =+ failUnpack $+ toSomeError $+ RanOutOfBytesError+ { ranOutOfBytesRead = i+ , ranOutOfBytesAvailable = len+ , ranOutOfBytesRequested = n+ }+ -- Check that we still have enough bytes, while guarding against integer overflow.+ join $ state $ \i@(I# i#) ->+ case addIntC# i# n# of+ (# adv#, 0# #) ->+ if len < I# adv#+ then (failOutOfBytes i, i)+ else (pure i, I# adv#)+ _ -> (failOutOfBytes i, i)+{-# INLINE guardAdvanceUnpack #-}++-- | Serialize a type into an unpinned `ByteArray`+--+-- ====__Examples__+--+-- >>> :set -XTypeApplications+-- >>> unpack @[Int] $ pack ([1,2,3,4,5] :: [Int])+-- Right [1,2,3,4,5]+pack :: forall a. (MemPack a, HasCallStack) => a -> ByteArray+pack = packByteArray False+{-# INLINE pack #-}++-- | Serialize a type into a pinned `ByteString`+packByteString :: forall a. (MemPack a, HasCallStack) => a -> ByteString+packByteString = pinnedByteArrayToByteString . packByteArray True+{-# INLINE packByteString #-}++-- | Serialize a type into an unpinned `ShortByteString`+packShortByteString :: forall a. (MemPack a, HasCallStack) => a -> ShortByteString+packShortByteString = byteArrayToShortByteString . pack+{-# INLINE packShortByteString #-}++-- | Same as `pack`, but allows controlling the pinnedness of allocated memory+packByteArray ::+ forall a.+ (MemPack a, HasCallStack) =>+ -- | Should the array be allocated in pinned memory?+ Bool ->+ a ->+ ByteArray+packByteArray isPinned a =+ runST $ packMutableByteArray isPinned a >>= freezeMutableByteArray+{-# INLINE packByteArray #-}++-- | Same as `packByteArray`, but produces a mutable array instead+packMutableByteArray ::+ forall a s.+ (MemPack a, HasCallStack) =>+ -- | Should the array be allocated in pinned memory?+ Bool ->+ a ->+ ST s (MutableByteArray s)+packMutableByteArray isPinned a = do+ let len = packedByteCount a+ mba <- newMutableByteArray isPinned len+ filledBytes <- execStateT (runPack (packM a) mba) 0+ when (filledBytes /= len) $+ if (filledBytes < len)+ then+ error $+ "Some bug in 'packM' was detected. Buffer of length " <> showBytes len+ ++ " was not fully filled while packing " <> typeName @a+ ++ ". Unfilled " <> showBytes (len - filledBytes) <> "."+ else+ -- This is a critical error, therefore we are not gracefully failing this unpacking+ error $+ "Potential buffer overflow. Some bug in 'packM' was detected while packing " <> typeName @a+ ++ ". Filled " <> showBytes (filledBytes - len) <> " more than allowed into a buffer of length "+ ++ show len+ pure mba+{-# INLINEABLE packMutableByteArray #-}++-- | 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+ let len = bufferByteCount b+ res@(_, consumedBytes) <- runStateT (runUnpack unpackM b) 0+ when (consumedBytes > len) $+ -- This is a critical error, therefore we are not gracefully failing this unpacking+ error $+ "Potential buffer overflow. Some bug in 'unpackM' was detected while unpacking " <> typeName @a+ ++ ". Consumed " <> showBytes (consumedBytes - len) <> " more than allowed from a buffer of length "+ ++ show len+ pure res+{-# INLINEABLE unpackLeftOver #-}++-- | Unpack a memory `Buffer` into a type using its `MemPack` instance. Besides potential+-- unpacking failures due to a malformed buffer it will also fail the supplied `Buffer`+-- was not fully consumed. Use `unpackLeftOver`, whenever a partially consumed buffer is+-- possible.+unpack :: forall a b. (MemPack a, Buffer b, HasCallStack) => b -> Either SomeError a+unpack = first fromMultipleErrors . runFailAgg . unpackFail+{-# INLINE unpack #-}++-- | Same as `unpack` except fails in a `Fail` monad, instead of `Either`.+unpackFail :: forall a b. (MemPack a, Buffer b, HasCallStack) => b -> Fail SomeError a+unpackFail b = do+ let len = bufferByteCount b+ (a, consumedBytes) <- unpackLeftOver b+ when (consumedBytes /= len) $+ failT $+ toSomeError $+ NotFullyConsumedError+ { notFullyConsumedRead = consumedBytes+ , notFullyConsumedAvailable = len+ , notFullyConsumedTypeName = typeName @a+ }+ pure a+{-# INLINEABLE unpackFail #-}++-- | Same as `unpackFail` except fails in any `MonadFail`, instead of `Fail`.+unpackMonadFail :: forall a b m. (MemPack a, Buffer b, F.MonadFail m) => b -> m a+unpackMonadFail = either (F.fail . show) pure . unpack+{-# INLINE unpackMonadFail #-}++-- | Same as `unpack` except throws a runtime exception upon a failure+unpackError :: forall a b. (MemPack a, Buffer b, HasCallStack) => b -> a+unpackError = errorFail . unpackFail+{-# INLINE unpackError #-}++-- | Variable length encoding for bounded types. This type of encoding will use less+-- memory for small values, but for larger values it will consume more memory and will be+-- slower during packing/unpacking.+newtype VarLen a = VarLen {unVarLen :: a}+ deriving (Eq, Ord, Show, Bounded, Enum, Num, Real, Integral, Bits, FiniteBits)++instance MemPack (VarLen Word16) where+ packedByteCount = packedVarLenByteCount+ {-# INLINE packedByteCount #-}+ packM v@(VarLen x) = p7 (p7 (p7 (errorTooManyBits "Word16"))) (numBits - 7)+ where+ p7 = packIntoCont7 x+ {-# INLINE p7 #-}+ numBits = packedVarLenByteCount v * 7+ {-# INLINE packM #-}+ unpackM = do+ let d7 = unpack7BitVarLen+ {-# INLINE d7 #-}+ VarLen <$> d7 (d7 (unpack7BitVarLenLast 0b_1111_1100)) 0 0+ {-# INLINE unpackM #-}++instance MemPack (VarLen Word32) where+ packedByteCount = packedVarLenByteCount+ {-# INLINE packedByteCount #-}+ packM v@(VarLen x) = p7 (p7 (p7 (p7 (p7 (errorTooManyBits "Word32"))))) (numBits - 7)+ where+ p7 = packIntoCont7 x+ {-# INLINE p7 #-}+ numBits = packedVarLenByteCount v * 7+ {-# INLINE packM #-}+ unpackM = do+ let d7 = unpack7BitVarLen+ {-# INLINE d7 #-}+ VarLen <$> d7 (d7 (d7 (d7 (unpack7BitVarLenLast 0b_1111_0000)))) 0 0+ {-# INLINE unpackM #-}++instance MemPack (VarLen Word64) where+ packedByteCount = packedVarLenByteCount+ {-# INLINE packedByteCount #-}+ packM v@(VarLen x) =+ p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (errorTooManyBits "Word64")))))))))) (numBits - 7)+ where+ p7 = packIntoCont7 x+ {-# INLINE p7 #-}+ numBits = packedVarLenByteCount v * 7+ {-# INLINE packM #-}+ unpackM = do+ let d7 = unpack7BitVarLen+ {-# INLINE d7 #-}+ VarLen <$> d7 (d7 (d7 (d7 (d7 (d7 (d7 (d7 (d7 (unpack7BitVarLenLast 0b_1111_1110))))))))) 0 0+ {-# INLINE unpackM #-}++instance MemPack (VarLen Word) where+ packedByteCount = packedVarLenByteCount+ {-# INLINE packedByteCount #-}+#if WORD_SIZE_IN_BITS == 32+ packM mba v@(VarLen x) = p7 (p7 (p7 (p7 (p7 (errorTooManyBits "Word"))))) (numBits - 7)+ where+ p7 = packIntoCont7 mba x+ {-# INLINE p7 #-}+ numBits = packedVarLenByteCount v * 7+ {-# INLINE packM #-}+ unpackM buf = do+ let d7 = unpack7BitVarLen buf+ {-# INLINE d7 #-}+ VarLen <$> d7 (d7 (d7 (d7 (unpack7BitVarLenLast buf 0b_1111_0000)))) 0 0+ {-# INLINE unpackM #-}+#elif WORD_SIZE_IN_BITS == 64+ packM v@(VarLen x) =+ p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (p7 (errorTooManyBits "Word")))))))))) (numBits - 7)+ where+ p7 = packIntoCont7 x+ {-# INLINE p7 #-}+ numBits = packedVarLenByteCount v * 7+ {-# INLINE packM #-}+ unpackM = do+ let d7 = unpack7BitVarLen+ {-# INLINE d7 #-}+ VarLen <$> d7 (d7 (d7 (d7 (d7 (d7 (d7 (d7 (d7 (unpack7BitVarLenLast 0b_1111_1110))))))))) 0 0+ {-# INLINE unpackM #-}+#else+#error "Only 32bit and 64bit systems are supported"+#endif++packedVarLenByteCount :: FiniteBits b => VarLen b -> Int+packedVarLenByteCount (VarLen x) =+ case (finiteBitSize x - countLeadingZeros x) `quotRem` 7 of+ (0, 0) -> 1+ (q, 0) -> q+ (q, _) -> q + 1+{-# INLINE packedVarLenByteCount #-}++errorTooManyBits :: [Char] -> a+errorTooManyBits name =+ error $ "Bug detected. Trying to pack more bits for " ++ name ++ " than it should be posssible"++packIntoCont7 ::+ (Bits t, Integral t) => t -> (Int -> Pack s ()) -> Int -> Pack s ()+packIntoCont7 x cont n+ | n <= 0 = packM (fromIntegral @_ @Word8 x .&. complement topBit8)+ | otherwise = do+ packM (fromIntegral @_ @Word8 (x `shiftR` n) .|. topBit8)+ cont (n - 7)+ where+ topBit8 :: Word8+ topBit8 = 0b_1000_0000+{-# INLINE packIntoCont7 #-}++-- | Decode a variable length integral value that is encoded with 7 bits of data+-- and the most significant bit (MSB), the 8th bit is set whenever there are+-- more bits following. Continuation style allows us to avoid+-- recursion. Removing loops is good for performance.+unpack7BitVarLen ::+ (Num a, Bits a, Buffer b) =>+ -- | Continuation that will be invoked if MSB is set+ (Word8 -> a -> Unpack 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+unpack7BitVarLen cont firstByte !acc = do+ b8 :: Word8 <- unpackM+ if b8 `testBit` 7+ then+ cont (if firstByte == 0 then b8 else firstByte) (acc `shiftL` 7 .|. fromIntegral (b8 `clearBit` 7))+ else pure (acc `shiftL` 7 .|. fromIntegral b8)+{-# INLINE unpack7BitVarLen #-}++unpack7BitVarLenLast ::+ forall t b.+ (Num t, Bits t, MemPack t, Buffer b) =>+ Word8 ->+ Word8 ->+ t ->+ Unpack 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+ -- bits supplied at the beginning.+ unless (firstByte .&. mask == 0b_1000_0000) $+ F.fail $+ "Unexpected bits for "+ ++ typeName @t+ ++ " were set in the first byte of 'VarLen': 0x" <> showHex firstByte ""+ pure res+{-# INLINE unpack7BitVarLenLast #-}++-- | This is a helper type useful for serializing number of elements in data+-- structures. It uses `VarLen` underneath, since sizes of common data structures aren't+-- too big. It also prevents negative values from being serialized and deserialized.+newtype Length = Length {unLength :: Int}+ deriving (Eq, Show, Num)++instance Bounded Length where+ minBound = 0+ maxBound = Length maxBound++instance Enum Length where+ toEnum n+ | n < 0 = error $ "toEnum: Length cannot be negative: " ++ show n+ | otherwise = Length n+ fromEnum = unLength++instance MemPack Length where+ packedByteCount = packedByteCount . VarLen . fromIntegral @Int @Word . unLength+ packM (Length n)+ | n < 0 = error $ "Length cannot be negative. Supplied: " ++ show n+ | otherwise = packM (VarLen (fromIntegral @Int @Word n))+ {-# INLINE packM #-}+ unpackM = do+ VarLen (w :: Word) <- unpackM+ when (testBit w (finiteBitSize w)) $+ F.fail $+ "Attempt to unpack negative length was detected: " ++ show (fromIntegral @Word @Int w)+ pure $ Length $ fromIntegral @Word @Int w+ {-# INLINE unpackM #-}++-- | This is a helper type that is useful for creating `MemPack` instances for sum types.+newtype Tag = Tag {unTag :: Word8}+ deriving (Eq, Ord, Show, Num, Enum, Bounded)++-- Manually defined instance, since ghc-8.6 has issues with deriving MemPack+instance MemPack Tag where+ packedByteCount _ = packedTagByteCount+ {-# INLINE packedByteCount #-}+ unpackM = unpackTagM+ {-# INLINE unpackM #-}+ packM = packTagM+ {-# INLINE packM #-}++packedTagByteCount :: Int+packedTagByteCount = SIZEOF_WORD8+{-# INLINE packedTagByteCount #-}++unpackTagM :: Buffer b => Unpack b Tag+unpackTagM = Tag <$> unpackM+{-# INLINE unpackTagM #-}++packTagM :: Tag -> Pack s ()+packTagM = packM . unTag+{-# INLINE packTagM #-}++unknownTagM :: forall a m b. (MemPack a, F.MonadFail m) => Tag -> m b+unknownTagM (Tag t) = F.fail $ "Unrecognized Tag: " ++ show t ++ " while decoding " ++ typeName @a++lift_# :: (State# s -> State# s) -> Pack s ()+lift_# f = Pack $ \_ -> lift $ st_ f+{-# INLINE lift_# #-}++st_ :: (State# s -> State# s) -> ST s ()+st_ f = ST $ \s# -> (# f s#, () #)+{-# INLINE st_ #-}
+ src/Data/MemPack/Buffer.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++-- |+-- Module : Data.MemPack.Buffer+-- Copyright : (c) Alexey Kuleshevich 2024+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+module Data.MemPack.Buffer 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 GHC.Exts+import GHC.ST+import GHC.ForeignPtr++-- | Immutable memory buffer+class Buffer b where+ bufferByteCount :: b -> Int++ buffer :: b -> (ByteArray# -> a) -> (Addr# -> a) -> a++instance Buffer ByteArray where+ bufferByteCount (ByteArray ba#) = I# (sizeofByteArray# ba#)+ {-# INLINE bufferByteCount #-}++ buffer (ByteArray ba#) f _ = f ba#+ {-# INLINE buffer #-}++instance Buffer SBS.ShortByteString where+ bufferByteCount = SBS.length+ {-# INLINE bufferByteCount #-}++ buffer (SBS.SBS ba#) f _ = f ba#+ {-# INLINE buffer #-}++instance Buffer BS.ByteString where+ bufferByteCount = BS.length+ {-# INLINE bufferByteCount #-}++ buffer bs _ f =+ runST $ withPtrByteStringST bs $ \(Ptr addr#) -> pure $! f addr#+ {-# INLINE buffer #-}+++newMutableByteArray :: Bool -> 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 #-}++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.+withPtrByteStringST :: BS.ByteString -> (Ptr a -> ST s b) -> ST s b+#if MIN_VERSION_bytestring(0,11,0)+withPtrByteStringST (BS.BS (ForeignPtr addr# ptrContents) _) f = do+#else+withPtrByteStringST (BS.PS (ForeignPtr addr0# ptrContents) (I# offset#) _) f = do+ let !addr# = addr0# `plusAddr#` offset#+#endif+ !r <- f (Ptr addr#)+ -- It is safe to use `touch#` within ST, so `unsafeCoerce#` is OK+ ST $ \s# -> (# unsafeCoerce# (touch# ptrContents (unsafeCoerce# s#)), () #)+ pure r+{-# INLINE withPtrByteStringST #-}++pinnedByteArrayToByteString :: ByteArray -> BS.ByteString+pinnedByteArrayToByteString (ByteArray ba#) =+ BS.PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#))+{-# INLINE pinnedByteArrayToByteString #-}++pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a+pinnedByteArrayToForeignPtr ba# =+ ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#))+{-# INLINE pinnedByteArrayToForeignPtr #-}+++byteArrayToShortByteString :: ByteArray -> SBS.ShortByteString+byteArrayToShortByteString (ByteArray ba#) = SBS.SBS ba#+{-# INLINE byteArrayToShortByteString #-}++byteArrayFromShortByteString :: SBS.ShortByteString -> ByteArray+byteArrayFromShortByteString (SBS.SBS ba#) = ByteArray ba#+{-# INLINE byteArrayFromShortByteString #-}
+ src/Data/MemPack/Error.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module : Data.MemPack.Error+-- Copyright : (c) Alexey Kuleshevich 2024+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <alexey@kuleshevi.ch>+-- Stability : experimental+-- Portability : non-portable+module Data.MemPack.Error where++import Control.Exception+import Data.List.NonEmpty as NE+import Data.Text (Text)+import Data.Typeable+import GHC.Exts++data SomeError where+ SomeError :: (Typeable e, Error e) => e -> SomeError++instance Show SomeError where+ showsPrec p (SomeError e) = showsPrec p e++instance Exception SomeError++-- | Very similar interface to `Exceptions`, except not intended for run time exceptions.+class Show e => Error e where+ toSomeError :: e -> SomeError+ default toSomeError :: Typeable e => e -> SomeError+ toSomeError = SomeError++ fromSomeError :: SomeError -> Maybe e+ default fromSomeError :: Typeable e => SomeError -> Maybe e+ fromSomeError (SomeError t) = cast t++instance Error SomeError where+ toSomeError = id+ fromSomeError = Just++newtype TextError = TextError Text+ deriving newtype (Eq, Show, IsString)++instance Error TextError++instance IsString SomeError where+ fromString = toSomeError . TextError . fromString++newtype ManyErrors = ManyErrors (NonEmpty SomeError)+ deriving (Show)++instance Error ManyErrors++data UnknownError = UnknownError+ deriving (Show)++instance Error UnknownError++fromMultipleErrors :: [SomeError] -> SomeError+fromMultipleErrors es =+ case es of+ [] -> toSomeError UnknownError+ [e] -> e+ e : rest -> toSomeError $ ManyErrors (e :| rest)++data RanOutOfBytesError = RanOutOfBytesError+ { ranOutOfBytesRead :: Int+ , ranOutOfBytesAvailable :: Int+ , ranOutOfBytesRequested :: Int+ }+ deriving (Eq, Ord)++instance Show RanOutOfBytesError where+ show RanOutOfBytesError{..} =+ "Ran out of bytes. Read "+ <> showBytes ranOutOfBytesRead+ <> " out of "+ <> showBytes ranOutOfBytesAvailable+ <> ". Requested to read "+ <> showBytes ranOutOfBytesRequested+ <> " more."++instance Error RanOutOfBytesError++data NotFullyConsumedError = NotFullyConsumedError+ { notFullyConsumedRead :: Int+ , notFullyConsumedAvailable :: Int+ , notFullyConsumedTypeName :: String+ }+ deriving (Eq, Ord)++instance Show NotFullyConsumedError where+ show NotFullyConsumedError{..} =+ "Buffer of length " <> showBytes notFullyConsumedAvailable+ ++ " was not fully consumed while unpacking '" <> notFullyConsumedTypeName+ ++ "'. Unconsumed " <> showBytes (notFullyConsumedAvailable - notFullyConsumedRead)+ ++ " was leftover."++instance Error NotFullyConsumedError++showBytes :: Int -> String+showBytes 1 = "1 byte"+showBytes n = show n ++ " bytes"
+ tests/Main.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}++module Main where++import qualified Test.MemPackSpec as MemPack (spec)+import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Hspec.Runner++config :: Config+#if !(MIN_VERSION_hspec(2,8,0))+config = defaultConfig+#else+config =+ defaultConfig+ { configTimes = True+ , configColorMode = ColorAlways+ }+#endif++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetEncoding stdout utf8+ hspecWith config $ do+ MemPack.spec
+ tests/Test/Common.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Common (+ module X,+ QC (..),+) where++import Data.Array.Byte (ByteArray (..))+import Data.ByteString (ByteString)+import Data.ByteString.Short.Internal as SBS (ShortByteString (..))+import Data.MemPack.Buffer (byteArrayFromShortByteString)+import System.Random.Stateful+import Test.Hspec as X+import Test.Hspec.QuickCheck as X+import Test.QuickCheck as X+import Test.QuickCheck.Gen (Gen (MkGen))++data QC = QC++instance StatefulGen QC Gen where+ uniformWord32 QC = MkGen (\r _n -> runStateGen_ r uniformWord32)+ {-# INLINE uniformWord32 #-}+ uniformWord64 QC = MkGen (\r _n -> runStateGen_ r uniformWord64)+ {-# INLINE uniformWord64 #-}+ uniformShortByteString k QC =+ MkGen (\r _n -> runStateGen_ r (uniformShortByteString k))+ {-# INLINE uniformShortByteString #-}++instance Arbitrary ByteArray where+ arbitrary = qcByteArray . getNonNegative =<< arbitrary++instance Arbitrary ByteString where+ arbitrary = qcByteString . getNonNegative =<< arbitrary++instance Arbitrary SBS.ShortByteString where+ arbitrary = qcShortByteString . getNonNegative =<< arbitrary++qcByteArray :: Int -> Gen ByteArray+qcByteArray n = byteArrayFromShortByteString <$> qcShortByteString n++qcByteString :: Int -> Gen ByteString+qcByteString n = uniformByteStringM (fromIntegral n) QC++qcShortByteString :: Int -> Gen SBS.ShortByteString+qcShortByteString n = uniformShortByteString (fromIntegral n) QC
+ tests/Test/MemPackSpec.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.MemPackSpec (spec) where++import Numeric.Natural+import Control.Applicative ((<|>))+import Control.Monad hiding (fail)+import qualified Control.Monad.Fail as F+import Data.Array.Byte (ByteArray)+import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString)+import Data.Complex+import Data.Either (isLeft)+import Data.Function (fix)+import Data.Int+import Data.MemPack+import Data.MemPack.Buffer+import Data.MemPack.Error+import Data.Ratio+import Data.Word+import Foreign.Ptr (IntPtr (..), Ptr, intPtrToPtr)+import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr)+import System.Random.Stateful+import Test.Common++-- | Generate extrema around boundaries+newtype E a = E {unE :: a}+ deriving (Eq, Ord, Show, Num, Real, Enum, Bounded, Integral)+#if __GLASGOW_HASKELL__ >= 808+ -- We also want to test GND for compiler versions that can handle it+ deriving newtype MemPack+#else+-- Manually defined instance, since ghc-8.6 has issues with deriving MemPack+instance MemPack a => MemPack (E a) where+ typeName = typeName @a+ packedByteCount = packedByteCount . unE+ unpackM = E <$> unpackM+ packM = packM . unE+#endif++instance Random Length++deriving instance Random Tag++instance Uniform Length where+ uniformM = uniformEnumM+instance UniformRange Length where+ uniformRM = uniformEnumRM++instance Arbitrary Length where+ -- Fun fact: `abs minBound == minBound` for Int, so instead of abs we clear top most+ arbitrary = Length . (\x -> x `clearBit` (finiteBitSize x - 1)) <$> arbitrary++deriving instance Arbitrary Tag++instance Arbitrary (Ptr a) where+ arbitrary = intPtrToPtr . IntPtr . unE <$> arbitrary++instance Arbitrary (StablePtr a) where+ arbitrary = castPtrToStablePtr <$> arbitrary++instance Show (StablePtr a) where+ show = show . castStablePtrToPtr++instance (Arbitrary a, Bounded a, Enum a, Random a) => Arbitrary (E a) where+ arbitrary =+ E+ <$> frequency+ [ (25, arbitrary)+ , (25, chooseAny)+ , (25, choose (minBound, iter succ minBound 100)) -- add a 100+ , (25, choose (iter pred maxBound 100, maxBound)) -- subtract a 100+ ]+ where+ iter :: (a -> a) -> a -> Int -> a+ iter f = fix (\loop c i -> if i <= 0 then c else loop (f c) (i - 1))++instance {-# OVERLAPPING #-} Arbitrary (E Integer) where+ arbitrary =+ E+ <$> frequency+ [ (15, arbitrary)+ , (25, chooseAny)+ , (25, choose (fromIntegral (maxBound :: Int), fromIntegral (maxBound :: Word)))+ , (25, choose (negate (fromIntegral (maxBound :: Word)), fromIntegral (minBound :: Int)))+ , (5, fact <$> choose (21, 300))+ , (5, negate . fact <$> choose (21, 300))+ ]+ where++instance {-# OVERLAPPING #-} Arbitrary (E Natural) where+ arbitrary =+ E+ <$> frequency+ [ (15, fromInteger . getNonNegative <$> arbitrary)+ , (25, uniformRM (0, fromIntegral (maxBound :: Word)) QC)+ , (25, uniformRM (fromIntegral (maxBound :: Word), 2 * fromIntegral (maxBound :: Word)) QC)+ , (5, fact . fromInteger <$> choose (21, 300))+ ]+++-- factorial for generating some large numbers+fact :: (Ord a, Num a) => a -> a+fact = go 1+ where+ go !acc n+ | n <= 1 = acc+ | otherwise = go (acc * n) (n - 1)++deriving instance Random a => Random (VarLen a)+deriving instance Arbitrary a => Arbitrary (VarLen a)++data Backtrack+ = IntCase Int+ | Word16Case Word16+ deriving (Show, Eq)++instance Arbitrary Backtrack where+ arbitrary =+ oneof [IntCase . unE <$> arbitrary, Word16Case . unE <$> arbitrary]++instance MemPack Backtrack where+ packedByteCount =+ (+ 1) . \case+ IntCase i -> packedByteCount i+ Word16Case i -> packedByteCount i+ packM = \case+ IntCase i -> packM (Tag 0) >> packM i+ Word16Case i -> packM (Tag 1) >> packM i+ unpackM =+ (IntCase <$> unpackCase 0) <|> (Word16Case <$> unpackCase 1)+ where+ unpackCase :: (Buffer b, MemPack a) => Tag -> Unpack b a+ unpackCase t = do+ t' <- unpackM+ unless (t == t') $ F.fail "Tag mismatch"+ unpackM++expectRoundTrip :: forall a. (MemPack a, Eq a, Show a) => a -> Expectation+expectRoundTrip a = do+ unpackError (pack a) `shouldBe` a+ unpackError (packByteString a) `shouldBe` a++expectNotFullyConsumed ::+ forall a. (MemPack a, Show a) => a -> NonEmptyList Word8 -> Expectation+expectNotFullyConsumed a (NonEmpty xs) = do+ let extraByteCount = length xs+ failOnExtra :: (Buffer b, Semigroup b) => b -> b -> Expectation+ failOnExtra buf extra =+ case unpack (buf <> extra) :: Either SomeError a of+ Left e+ | Just err <- fromSomeError e -> do+ notFullyConsumedRead err `shouldBe` bufferByteCount buf+ notFullyConsumedAvailable err `shouldBe` bufferByteCount buf+ + packedByteCount (Length extraByteCount) -- account for list length+ + extraByteCount+ notFullyConsumedTypeName err `shouldBe` typeName @a+ | otherwise -> expectationFailure $ "Unexpected failure: " ++ show e+ Right res -> expectationFailure $ "Unexpectedly unpacked: " ++ show res+ failOnExtra (pack a) (pack xs)+ failOnExtra (packByteString a) (packByteString xs)++memPackSpec :: forall a. (MemPack a, Arbitrary a, Eq a, Show a) => Spec+memPackSpec =+ describe (typeName @a) $ do+ prop "RoundTrip" $ expectRoundTrip @a+ describe "Fail on empty" $ do+ let checkRanOutOfBytes someErr+ | Just err <- fromSomeError someErr = do+ ranOutOfBytesRead err `shouldBe` 0+ ranOutOfBytesAvailable err `shouldBe` 0+ ranOutOfBytesRequested err `shouldSatisfy` (> 0)+ | otherwise = expectationFailure $ "Unexpected failure: " ++ show someErr+ -- Check that the only kind of failure we get is RanOutOfBytes+ failOnEmpty emptyBuffer =+ case unpack emptyBuffer :: Either SomeError a of+ Left e+ | Just (ManyErrors errs) <- fromSomeError e -> mapM_ checkRanOutOfBytes errs+ | otherwise -> checkRanOutOfBytes e+ Right res -> expectationFailure $ "Unexpectedly unpacked: " ++ show res+ it "ByteArray" $ failOnEmpty (mempty :: ByteArray)+ it "ByteString" $ failOnEmpty (mempty :: ByteString)+ it "ShortByteString" $ failOnEmpty (mempty :: ShortByteString)+ prop "Fail on too much" $ expectNotFullyConsumed @a++spec :: Spec+spec = do+ prop "RoundTrip" $ expectRoundTrip @()+ memPackSpec @(Ptr ())+ memPackSpec @(StablePtr ())+ memPackSpec @Float+ memPackSpec @Double+ memPackSpec @Bool+ memPackSpec @(E Char)+ memPackSpec @(E Int)+ memPackSpec @(E Int8)+ memPackSpec @(E Int16)+ memPackSpec @(E Int32)+ memPackSpec @(E Int64)+ memPackSpec @(E Word)+ memPackSpec @(E Word8)+ memPackSpec @(E Word16)+ memPackSpec @(E Word32)+ memPackSpec @(E Word64)+ memPackSpec @[E Int]+ memPackSpec @[E Word]+ memPackSpec @(E Int, E Word)+ memPackSpec @(E Int8, E Word8, E Char)+ memPackSpec @(E Int16, E Word16, Float, Double)+ memPackSpec @(E Int32, E Word32, Float, Double, Ptr Char)+ memPackSpec @(E Int64, E Word64, Length, VarLen Word, StablePtr Char, [VarLen Word32])+ memPackSpec @(Tag, Int, Int8, Int16, Int32, Int64, Backtrack)+ memPackSpec @(E (VarLen Word))+ memPackSpec @(E (VarLen Word16))+ memPackSpec @(E (VarLen Word32))+ memPackSpec @(E (VarLen Word64))+ memPackSpec @(E Tag)+ memPackSpec @(E Length)+ memPackSpec @(E Integer)+ memPackSpec @(E Natural)+ memPackSpec @(Maybe String)+ memPackSpec @(Either Float Double)+ memPackSpec @(Complex (E Int))+ memPackSpec @(Ratio (E Int))+ memPackSpec @ByteArray+ memPackSpec @ByteString+ memPackSpec @ShortByteString+ memPackSpec @Backtrack+ prop "Out of bound char" $ forAll (choose (0x110000, maxBound :: Word32)) $ \w32 ->+ unpack @Char (pack w32) `shouldSatisfy` isLeft+ prop "Zero denominator" $ \x -> do+ unpack @(Ratio Int8) (pack (x :: Int8, 0 :: Int8)) `shouldSatisfy` isLeft