persist 0.1.1.5 → 1.0.0.0

raw patch · 5 files changed

+1090/−600 lines, 5 filesdep ~QuickCheckdep ~basedep ~bytestringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base, bytestring, containers, test-framework, test-framework-quickcheck2, text

API changes (from Hackage documentation)

Files

• Changelog.md +88/−0
• persist.cabal +68/−56
• src/Data/Persist.hs +584/−374
• src/Data/Persist/Internal.hs +185/−87
• tests/RoundTrip.hs +165/−83

@@ -0,0 +1,88 @@+## Changes from 0.1.1.5 to 1.0.0.0 ##++  * Use DerivingVia to reduce repetititon for base instances+    +    Add three helper type classes: HasEndianness, SerializeAs,+    ReinterpretAs, and two newtypes: ViaSerializeAs and ViaReinterpretAs.+    HasEndianness allows us to create persist instances for `BigEndian a`+    and `LittleEndian a` without repetititon. SerializeAs allows anyone to+    supply a cast function in both directions and then re-use either a+    HasEndianness instance or a Persist instance. See the source file for+    example uses.++  * Add unsafe versions of put/get and helpers+    +    Allow for Persist instances to reserve specific sizes ahead of time and+    then elide the checks while serializing. As an implemented example, we+    allocate space for the length of a ByteString and the bytes in the+    ByteString together. For characters as well, we allocate the space all+    at once. This technique would be useful for arrays of fixed size+    elements, like unboxed vectors.++  * Add getPrefix and unsafeGetPrefix+    +    It often occurs when deserializing a custom format that we need to+    recursively deserialize a subcomponent from the next `n` bytes. The+    naive way to do this would be to get a `ByteString` for those n bytes,+    and then run the appropriate `Get` on that `ByteString`. To simplify+    this process, introduce `getPrefix` and `unsafeGetPrefix`. These+    manipulate the `Get` internals to expose only the appropriate bytes to+    the sub-deserializer. This avoids repeated copying, and even repeated+    `ByteString` construction.++  * Add length backpatching+    +    There are many serialized formats where a serialized sub-value is+    prefixed by its length. The simplest way to find the serialized length+    of a value is to serialize it and then to measure the length. For+    formats that use a fixed number of bytes for this length, we can avoid+    copying and also walking a data structure twice: Once to find the size,+    and again to write the data with the known size. It is straightforward+    to use this. Reserve the size, serialize the sub-value, then resolve the+    size, with the correct endianness and inclusivity.+    +    We do this by reserving the bytes ahead of time and returning a+    `PutSize` handle that can be used later to fill in the result.+    Currently, the library handles computing the appropriate size, which can+    be filled in either Big or Little endian, and either inclusive or+    exclusive of the size itself. DHCPv6 packets use this style of+    length-value encoding. As does Cassandra's encoding format, and MongoDB+    as well. MongoDB uses this same backpatching optimization.++  * Switch to NoFieldSelectors and OverloadedRecordDot+    +    GHC has supported OverloadedRecordDot and NoFieldSelectors since 9.2+    Switch away from prefixed names and instead just use names and record+    dot syntax. There are a handful of now-ambiguous updates. They were+    resolved using a small lambda and RecordWildCards/NamedFieldPuns. This+    is a breaking change, but there are several and we are planning on a new+    major release.++  * Bump version bounds to match ghc 9.2+    +    Bump tested-with to match the versions of ghc 9.2--9.12 that were+    manually tested. Bump versions of any libraries included with ghc to+    match the minimum version included with ghc 9.2++  * Add Kyle Butt as maintainer and author++  * Borrow improved error message handling from Store++  * Improve interaction with bytestring library+    +    Avoid a copy for a strict ByteString with only one chunk by calling+    `reallocBytes` and then building the ByteString directly by recording a+    finalizer.+    +    Add support for running a put and producing a lazy ByteString. Turn each+    chunk into a strict ByteString with the appropriate finalizer, and then+    use `foldlM` to reverse the chunks and build the lazy ByteString at the+    same time.++  * Add resolveSize helpers that write a computed size+    +    This makes list serialization much faster. It makes almost all of the+    serialization benchmarks competitive with store. The remaining gap is+    due to reinterpretCast. Copying a Double to tmp and then again to the+    buffer is slower. But this is a simple win that puts the new reservation+    code to good use.

@@ -1,71 +1,83 @@-name:                   persist-version:                0.1.1.5-license:                BSD3-license-file:           LICENSE-author:                 Daniel Mendler <mail@daniel-mendler.de>,-                        Michael Sloan <sloan@fpcomplete.com>,-                        FP Complete,-                        Lennart Kolmodin <kolmodin@dtek.chalmers.se>,-                        Galois Inc.,-                        Lemmih <lemmih@gmail.com>,-                        Bas van Dijk <v.dijk.bas@gmail.com>-maintainer:             Daniel Mendler <mail@daniel-mendler.de>-category:               Data, Parsing-stability:              provisional-build-type:             Simple-cabal-version:          >= 1.10-synopsis:               Minimal serialization library with focus on performance-homepage:               https://github.com/minad/persist-tested-with:            GHC == 8.4.4, GHC == 8.6.4+cabal-version: 3.6+name: persist+version: 1.0.0.0+license: BSD-3-Clause+license-file: LICENSE+author:+  Daniel Mendler <mail@daniel-mendler.de>,+  Michael Sloan <sloan@fpcomplete.com>,+  FP Complete,+  Lennart Kolmodin <kolmodin@dtek.chalmers.se>,+  Galois Inc.,+  Lemmih <lemmih@gmail.com>,+  Bas van Dijk <v.dijk.bas@gmail.com>,+  Kyle Butt <kyle@iteratee.net> +maintainer: Kyle Butt <kyle@iteratee.net>+category: Data, Parsing+stability: provisional+build-type: Simple+synopsis: Minimal serialization library with focus on performance+homepage: https://github.com/minad/persist+tested-with:+  ghc ==9.2.8+  ghc ==9.4.8+  ghc ==9.6.7+  ghc ==9.8.4+  ghc ==9.10.2+  ghc ==9.12.2+extra-doc-files: Changelog.md+ description:-  A binary serialization library with focus on performance similar to store and cereal+  A binary serialization library with focus on performance similar to store and+  cereal. Includes utilities to match externally specified data formats.  source-repository head-  type:     git-  location: git://github.com/minad/persist+  type: git+  location: https://github.com/minad/persist  flag force-unaligned-        manual: True-        default: False+  manual: True+  default: False+ flag force-aligned-        manual: True-        default: False+  manual: True+  default: False  library-        default-language:       Haskell2010--        build-depends:          base >= 4.7 && < 5, containers,-                                bytestring >= 0.10.4 && < 1,-                                text >= 1.2 && < 1.3--        if !flag(force-aligned) && (flag(force-unaligned) || arch(i386) || arch(x86_64))-                cpp-options: -DUNALIGNED_MEMORY--        hs-source-dirs:         src--        exposed-modules:        Data.Persist,-                                Data.Persist.Internal--        ghc-options:            -Wall -O2 -funbox-strict-fields+  default-language: Haskell2010+  build-depends:+    base >=4.16 && <5,+    bytestring >=0.11.1 && <1,+    containers >=0.6.5.1 && <0.9,+    text >=1.2.5 && <2.2, +  if !flag(force-aligned) && (flag(force-unaligned) || arch(i386) || arch(x86_64))+    cpp-options: -DUNALIGNED_MEMORY+  hs-source-dirs: src+  exposed-modules:+    Data.Persist+    Data.Persist.Internal +  ghc-options:+    -Wall+    -funbox-strict-fields  test-suite test-persist-        default-language:       Haskell2010--        type:                   exitcode-stdio-1.0--        build-depends:          base == 4.*,-                                bytestring >= 0.9,-                                QuickCheck,-                                test-framework,-                                test-framework-quickcheck2,-                                persist,-                                text >= 1.2 && < 1.3+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  build-depends:+    QuickCheck >=2.16.0 && <2.17,+    base,+    bytestring,+    persist,+    test-framework >=0.8.2 && <0.9,+    test-framework-quickcheck2 >=0.3.0 && <0.4,+    text, -        main-is:                Main.hs-        other-modules:          RoundTrip-                                GetTests+  main-is: Main.hs+  other-modules:+    GetTests+    RoundTrip -        hs-source-dirs:         tests+  hs-source-dirs: tests

@@ -1,85 +1,106 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}--module Data.Persist (+{-# LANGUAGE NoFieldSelectors #-} -    -- * The Persist class-      Persist(..)+module Data.Persist+  ( -- * The Persist class+    Persist (..)      -- * Endianness-    , HostEndian-    , BigEndian(..)-    , LittleEndian(..)+  , HostEndian+  , BigEndian (..)+  , LittleEndian (..) +    -- * Helpers for writing Persist instances+  , HasEndianness (..)+  , ReinterpretAs (..)+  , SerializeAs (..)+  , ViaReinterpretAs (..)+  , ViaSerializeAs (..)+     -- * Serialization-    , encode-    , decode+  , encode+  , encodeLazy+  , decode      -- * The Get type-    , Get-    , runGet-    , ensure-    , skip-    , getBytes-    , getByteString-    , remaining-    , eof-    , getHE-    , getLE-    , getBE+  , Get+  , runGet+  , ensure+  , skip+  , getBytes+  , getByteString+  , remaining+  , eof+  , getPrefix+  , getHE+  , getLE+  , getBE      -- * The Put type-    , Put-    , runPut-    , evalPut-    , grow-    , putByteString-    , putHE-    , putLE-    , putBE-) where+  , Put+  , runPut+  , runPutLazy+  , evalPut+  , evalPutLazy+  , grow+  , putByteString+  , putHE+  , putLE+  , putBE -import Control.Monad-import Data.Bits+    -- * Size Reserve/Resolve+  , reserveSize+  , resolveSizeExclusiveBE+  , resolveSizeExclusiveLE+  , resolveSizeInclusiveBE+  , resolveSizeInclusiveLE+  , resolveSizeLE+  , resolveSizeBE+  ) where++import Control.Exception (throw)+import Control.Monad (forM_, when, (<$!>))+import Data.Bits (Bits (..)) import Data.ByteString (ByteString)-import Data.Int+import Data.IORef (readIORef)+import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) import Data.IntSet (IntSet)+import Data.Kind (Constraint, Type) import Data.List (unfoldr)-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Persist.Internal import Data.Proxy import Data.Sequence (Seq) import Data.Set (Set) import Data.Text (Text)-import Data.Word-import Foreign (Ptr, Storable(..), plusPtr, minusPtr, castPtr, withForeignPtr)-import GHC.Base (unsafeChr, ord)-import GHC.Exts (IsList(..))-import GHC.Generics-import GHC.Real (Ratio(..))-import GHC.TypeLits-import Numeric.Natural+#ifdef UNALIGNED_MEMORY+import Data.Word (Word8, Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64)+#else+import Data.Word (Word8, Word16, Word32, Word64)+#endif import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L@@ -88,11 +109,28 @@ import qualified Data.Monoid as M import qualified Data.Text.Encoding as TE import qualified Data.Tree as T+import Foreign (Ptr, Storable (..), castPtr, minusPtr, plusPtr, withForeignPtr)+import Foreign.Marshal.Utils (copyBytes)+import GHC.Base (ord, unsafeChr)+import GHC.Exts (IsList (..))+import GHC.Generics+import GHC.Real (Ratio (..))+import GHC.TypeLits+  ( ErrorMessage (..)+  , KnownNat+  , Nat+  , Natural+  , Symbol+  , TypeError+  , natVal+  , type (+)+  , type (<=?)+  )  #include "MachDeps.h" -putHE :: Persist (HostEndian a) => a -> Put ()-getHE :: Persist (HostEndian a) => Get a+putHE :: (Persist (HostEndian a)) => a -> Put ()+getHE :: (Persist (HostEndian a)) => Get a {-# INLINE putHE #-} {-# INLINE getHE #-} @@ -146,15 +184,15 @@ {-# INLINE peekByte #-}  poke16LE p y = do-  pokeByte p $ y+  pokeByte p y   pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8  poke16BE p y = do   pokeByte p $ y `unsafeShiftR` 8-  pokeByte (p `plusPtr` 1) $ y+  pokeByte (p `plusPtr` 1) y  poke32LE p y = do-  pokeByte p $ y+  pokeByte p y   pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8   pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 16   pokeByte (p `plusPtr` 3) $ y `unsafeShiftR` 24@@ -163,10 +201,10 @@   pokeByte p $ y `unsafeShiftR` 24   pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 16   pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 8-  pokeByte (p `plusPtr` 3) $ y+  pokeByte (p `plusPtr` 3) y  poke64LE p y = do-  pokeByte p $ y+  pokeByte p y   pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8   pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 16   pokeByte (p `plusPtr` 3) $ y `unsafeShiftR` 24@@ -183,7 +221,7 @@   pokeByte (p `plusPtr` 4) $ y `unsafeShiftR` 24   pokeByte (p `plusPtr` 5) $ y `unsafeShiftR` 16   pokeByte (p `plusPtr` 6) $ y `unsafeShiftR` 8-  pokeByte (p `plusPtr` 7) $ y+  pokeByte (p `plusPtr` 7) y  peek16LE p = do   !x0 <- peekByte @Word16 p@@ -327,18 +365,27 @@ peek64BE p = fromBE64 <$!> peek (castPtr @_ @Word64 p) #endif -newtype BigEndian a = BigEndian { unBE :: a }+newtype BigEndian a = BigEndian {unBE :: a}   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) -newtype LittleEndian a = LittleEndian { unLE :: a }+newtype LittleEndian a = LittleEndian {unLE :: a}   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  class Persist t where   -- | Encode a value in the Put monad.   put :: t -> Put ()+   -- | Decode a value in the Get monad   get :: Get t +  -- | Encode a value without checking for sufficient size.+  unsafePut :: t -> Put ()+  unsafePut = put++  -- | Decode a value without checking for sufficient size.+  unsafeGet :: Get t+  unsafeGet = get+   default put :: (Generic t, GPersistPut (Rep t)) => t -> Put ()   put = gput . from @@ -346,109 +393,115 @@   get = to <$!> gget  -- | Encode a value using binary serialization to a strict ByteString.-encode :: Persist a => a -> ByteString+encode :: (Persist a) => a -> ByteString encode = runPut . put --- | Decode a value from a strict ByteString, reconstructing the original--- structure.-decode :: Persist a => ByteString -> Either String a+-- | Encode a value using binary serialization to a lazy ByteString.+encodeLazy :: (Persist a) => a -> L.ByteString+encodeLazy = runPutLazy . put+++{- | Decode a value from a strict ByteString, reconstructing the original+structure.+-}+decode :: (Persist a) => ByteString -> Either String a decode = runGet get -putLE :: Persist (LittleEndian a) => a -> Put ()+putLE :: (Persist (LittleEndian a)) => a -> Put () putLE = put . LittleEndian {-# INLINE putLE #-} -putBE :: Persist (BigEndian a) => a -> Put ()+putBE :: (Persist (BigEndian a)) => a -> Put () putBE = put . BigEndian {-# INLINE putBE #-} -getLE :: Persist (LittleEndian a) => Get a-getLE = unLE <$!> get+getLE :: forall a. (Persist (LittleEndian a)) => Get a+getLE = (.unLE) <$!> get @(LittleEndian a) {-# INLINE getLE #-} -getBE :: Persist (BigEndian a) => Get a-getBE = unBE <$!> get+getBE :: forall a. (Persist (BigEndian a)) => Get a+getBE = (.unBE) <$!> get @(BigEndian a) {-# INLINE getBE #-} -unsafePutByte :: Integral a => a -> Put ()+unsafePutByte :: (Integral a) => a -> Put () unsafePutByte x = Put $ \_ p -> do   poke p $ fromIntegral x   pure $! p `plusPtr` 1 :!: () {-# INLINE unsafePutByte #-} -unsafePut16LE :: Integral a => a -> Put ()+unsafePut16LE :: (Integral a) => a -> Put () unsafePut16LE x = Put $ \_ p -> do   poke16LE p $ fromIntegral x   pure $! p `plusPtr` 2 :!: () {-# INLINE unsafePut16LE #-} -unsafePut32LE :: Integral a => a -> Put ()+unsafePut32LE :: (Integral a) => a -> Put () unsafePut32LE x = Put $ \_ p -> do   poke32LE p $ fromIntegral x   pure $! p `plusPtr` 4 :!: () {-# INLINE unsafePut32LE #-} -unsafePut64LE :: Integral a => a -> Put ()+unsafePut64LE :: (Integral a) => a -> Put () unsafePut64LE x = Put $ \_ p -> do   poke64LE p $ fromIntegral x   pure $! p `plusPtr` 8 :!: () {-# INLINE unsafePut64LE #-} -unsafePut16BE :: Integral a => a -> Put ()+unsafePut16BE :: (Integral a) => a -> Put () unsafePut16BE x = Put $ \_ p -> do   poke16BE p $ fromIntegral x   pure $! p `plusPtr` 2 :!: () {-# INLINE unsafePut16BE #-} -unsafePut32BE :: Integral a => a -> Put ()+unsafePut32BE :: (Integral a) => a -> Put () unsafePut32BE x = Put $ \_ p -> do   poke32BE p $ fromIntegral x   pure $! p `plusPtr` 4 :!: () {-# INLINE unsafePut32BE #-} -unsafePut64BE :: Integral a => a -> Put ()+unsafePut64BE :: (Integral a) => a -> Put () unsafePut64BE x = Put $ \_ p -> do   poke64BE p $ fromIntegral x   pure $! p `plusPtr` 8 :!: () {-# INLINE unsafePut64BE #-} -unsafeGetByte :: Num a => Get a+unsafeGetByte :: (Num a) => Get a unsafeGetByte = Get $ \_ p -> do   x <- peek p   pure $! p `plusPtr` 1 :!: fromIntegral x {-# INLINE unsafeGetByte #-} -unsafeGet16LE :: Num a => Get a+unsafeGet16LE :: (Num a) => Get a unsafeGet16LE = Get $ \_ p -> do   x <- peek16LE p   pure $! p `plusPtr` 2 :!: fromIntegral x {-# INLINE unsafeGet16LE #-} -unsafeGet32LE :: Num a => Get a+unsafeGet32LE :: (Num a) => Get a unsafeGet32LE = Get $ \_ p -> do   x <- peek32LE p   pure $! p `plusPtr` 4 :!: fromIntegral x {-# INLINE unsafeGet32LE #-} -unsafeGet64LE :: Num a => Get a+unsafeGet64LE :: (Num a) => Get a unsafeGet64LE = Get $ \_ p -> do   x <- peek64LE p   pure $! p `plusPtr` 8 :!: fromIntegral x {-# INLINE unsafeGet64LE #-} -unsafeGet16BE :: Num a => Get a+unsafeGet16BE :: (Num a) => Get a unsafeGet16BE = Get $ \_ p -> do   x <- peek16BE p   pure $! p `plusPtr` 2 :!: fromIntegral x {-# INLINE unsafeGet16BE #-} -unsafeGet32BE :: Num a => Get a+unsafeGet32BE :: (Num a) => Get a unsafeGet32BE = Get $ \_ p -> do   x <- peek32BE p   pure $! p `plusPtr` 4 :!: fromIntegral x {-# INLINE unsafeGet32BE #-} -unsafeGet64BE :: Num a => Get a+unsafeGet64BE :: (Num a) => Get a unsafeGet64BE = Get $ \_ p -> do   x <- peek64BE p   pure $! p `plusPtr` 8 :!: fromIntegral x@@ -461,11 +514,11 @@ {-# INLINE reinterpretCast #-}  reinterpretCastPut :: (Storable a, Storable b) => a -> Put b-reinterpretCastPut x = Put $ \e p -> (p :!:) <$!> reinterpretCast (peTmp e) x+reinterpretCastPut x = Put $ \e p -> (p :!:) <$!> reinterpretCast e.tmp x {-# INLINE reinterpretCastPut #-}  reinterpretCastGet :: (Storable a, Storable b) => a -> Get b-reinterpretCastGet x = Get $ \e p -> (p :!:) <$!> reinterpretCast (geTmp e) x+reinterpretCastGet x = Get $ \e p -> (p :!:) <$!> reinterpretCast e.tmp x {-# INLINE reinterpretCastGet #-}  -- The () type need never be written to disk: values of singleton type@@ -476,232 +529,202 @@   get = pure ()   {-# INLINE get #-} -instance Persist Word8 where-  put x = do-    grow 1-    unsafePutByte x-  {-# INLINE put #-}--  get = do-    ensure 1-    unsafeGetByte-  {-# INLINE get #-}--instance Persist (LittleEndian Word16) where-  put x = do-    grow 2-    unsafePut16LE $ unLE x-  {-# INLINE put #-}+class HasEndianness a where+  unsafeGetLE :: Get a+  unsafePutLE :: a -> Put ()+  unsafeGetBE :: Get a+  unsafePutBE :: a -> Put ()+  endiannessSize :: Int -  get = do-    ensure 2-    LittleEndian <$!> unsafeGet16LE-  {-# INLINE get #-}+instance HasEndianness Word8 where+  unsafeGetLE = unsafeGetByte+  unsafeGetBE = unsafeGetByte+  unsafePutLE = unsafePutByte+  unsafePutBE = unsafePutByte+  endiannessSize = 1 -instance Persist (BigEndian Word16) where-  put x = do-    grow 2-    unsafePut16BE $ unBE x-  {-# INLINE put #-}+instance HasEndianness Word16 where+  unsafeGetLE = unsafeGet16LE+  {-# INLINE unsafeGetLE #-}+  unsafeGetBE = unsafeGet16BE+  {-# INLINE unsafeGetBE #-}+  unsafePutLE = unsafePut16LE+  {-# INLINE unsafePutLE #-}+  unsafePutBE = unsafePut16BE+  {-# INLINE unsafePutBE #-}+  endiannessSize = 2+  {-# INLINE endiannessSize #-} -  get = do-    ensure 2-    BigEndian <$!> unsafeGet16BE-  {-# INLINE get #-}+instance HasEndianness Word32 where+  unsafeGetLE = unsafeGet32LE+  {-# INLINE unsafeGetLE #-}+  unsafeGetBE = unsafeGet32BE+  {-# INLINE unsafeGetBE #-}+  unsafePutLE = unsafePut32LE+  {-# INLINE unsafePutLE #-}+  unsafePutBE = unsafePut32BE+  {-# INLINE unsafePutBE #-}+  endiannessSize = 4+  {-# INLINE endiannessSize #-} -instance Persist Word16 where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+instance HasEndianness Word64 where+  unsafeGetLE = unsafeGet64LE+  {-# INLINE unsafeGetLE #-}+  unsafeGetBE = unsafeGet64BE+  {-# INLINE unsafeGetBE #-}+  unsafePutLE = unsafePut64LE+  {-# INLINE unsafePutLE #-}+  unsafePutBE = unsafePut64BE+  {-# INLINE unsafePutBE #-}+  endiannessSize = 8+  {-# INLINE endiannessSize #-} -instance Persist (LittleEndian Word32) where+instance (HasEndianness a) => Persist (LittleEndian a) where   put x = do-    grow 4-    unsafePut32LE $ unLE x+    grow (endiannessSize @a)+    unsafePut x   {-# INLINE put #-} -  get = do-    ensure 4-    LittleEndian <$!> unsafeGet32LE-  {-# INLINE get #-}--instance Persist (BigEndian Word32) where-  put x = do-    grow 4-    unsafePut32BE $ unBE x-  {-# INLINE put #-}+  unsafePut = unsafePutLE . (.unLE)+  {-# INLINE unsafePut #-}    get = do-    ensure 4-    BigEndian <$!> unsafeGet32BE+    ensure (endiannessSize @a)+    unsafeGet   {-# INLINE get #-} -instance Persist Word32 where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+  unsafeGet = LittleEndian <$!> unsafeGetLE+  {-# INLINE unsafeGet #-} -instance Persist (LittleEndian Word64) where+instance (HasEndianness a) => Persist (BigEndian a) where   put x = do-    grow 8-    unsafePut64LE $ unLE x+    grow (endiannessSize @a)+    unsafePut x   {-# INLINE put #-} -  get = do-    ensure 8-    LittleEndian <$!> unsafeGet64LE-  {-# INLINE get #-}--instance Persist (BigEndian Word64) where-  put x = do-    grow 8-    unsafePut64BE $ unBE x-  {-# INLINE put #-}+  unsafePut = unsafePutBE . (.unBE)+  {-# INLINE unsafePut #-}    get = do-    ensure 8-    BigEndian <$!> unsafeGet64BE-  {-# INLINE get #-}--instance Persist Word64 where-  put = putLE-  {-# INLINE put #-}-  get = getLE+    ensure (endiannessSize @a)+    unsafeGet   {-# INLINE get #-} -instance Persist Int8 where-  put = put @Word8 . fromIntegral-  {-# INLINE put #-}-  get = fromIntegral <$!> get @Word8-  {-# INLINE get #-}+  unsafeGet = BigEndian <$!> unsafeGetBE+  {-# INLINE unsafeGet #-} -instance Persist (LittleEndian Int16) where-  put = put . fmap (fromIntegral @_ @Word16)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word16) <$!> get-  {-# INLINE get #-}+deriving via (LittleEndian Word8) instance Persist Word8+deriving via (LittleEndian Word16) instance Persist Word16+deriving via (LittleEndian Word32) instance Persist Word32+deriving via (LittleEndian Word64) instance Persist Word64 -instance Persist (BigEndian Int16) where-  put = put . fmap (fromIntegral @_ @Word16)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word16) <$!> get-  {-# INLINE get #-}+class SerializeAs a where+  type SerializeTarget a+  castPut :: a -> SerializeTarget a+  castGet :: SerializeTarget a -> a -instance Persist Int16 where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+instance SerializeAs Int8 where+  type SerializeTarget Int8 = Word8+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist (LittleEndian Int32) where-  put = put . fmap (fromIntegral @_ @Word32)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word32) <$!> get-  {-# INLINE get #-}+instance SerializeAs Int16 where+  type SerializeTarget Int16 = Word16+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist (BigEndian Int32) where-  put = put . fmap (fromIntegral @_ @Word32)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word32) <$!> get-  {-# INLINE get #-}+instance SerializeAs Int32 where+  type SerializeTarget Int32 = Word32+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist Int32 where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+instance SerializeAs Int64 where+  type SerializeTarget Int64 = Word64+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist (LittleEndian Int64) where-  put = put . fmap (fromIntegral @_ @Word64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word64) <$!> get-  {-# INLINE get #-}+newtype ViaSerializeAs a = MkViaSerializeAs a+  deriving (Eq, Ord, Show) -instance Persist (BigEndian Int64) where-  put = put . fmap (fromIntegral @_ @Word64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word64) <$!> get-  {-# INLINE get #-}+instance (SerializeAs a, HasEndianness (SerializeTarget a)) => HasEndianness (ViaSerializeAs a) where+  endiannessSize = endiannessSize @(SerializeTarget a)+  {-# INLINE endiannessSize #-}+  unsafeGetBE = MkViaSerializeAs . castGet <$!> unsafeGetBE+  {-# INLINE unsafeGetBE #-}+  unsafeGetLE = MkViaSerializeAs . castGet <$!> unsafeGetLE+  {-# INLINE unsafeGetLE #-}+  unsafePutBE (MkViaSerializeAs x) = unsafePutBE . castPut $! x+  {-# INLINE unsafePutBE #-}+  unsafePutLE (MkViaSerializeAs x) = unsafePutLE . castPut $! x+  {-# INLINE unsafePutLE #-} -instance Persist Int64 where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+deriving via (ViaSerializeAs Int8) instance HasEndianness Int8+deriving via (ViaSerializeAs Int16) instance HasEndianness Int16+deriving via (ViaSerializeAs Int32) instance HasEndianness Int32+deriving via (ViaSerializeAs Int64) instance HasEndianness Int64 -instance Persist (LittleEndian Double) where-  put x = reinterpretCastPut (unLE x) >>= putLE @Word64-  {-# INLINE put #-}-  get = getLE @Word64 >>= fmap LittleEndian . reinterpretCastGet-  {-# INLINE get #-}+deriving via (LittleEndian Int8) instance Persist Int8+deriving via (LittleEndian Int16) instance Persist Int16+deriving via (LittleEndian Int32) instance Persist Int32+deriving via (LittleEndian Int64) instance Persist Int64 -instance Persist (BigEndian Double) where-  put x = reinterpretCastPut (unBE x) >>= putBE @Word64-  {-# INLINE put #-}-  get = getBE @Word64 >>= fmap BigEndian . reinterpretCastGet-  {-# INLINE get #-}+instance SerializeAs Word where+  type SerializeTarget Word = Word64+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist Double where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+instance SerializeAs Int where+  type SerializeTarget Int = Int64+  castPut = fromIntegral+  castGet = fromIntegral -instance Persist (LittleEndian Float) where-  put x = reinterpretCastPut (unLE x) >>= putLE @Word32+instance (SerializeAs a, Persist (SerializeTarget a)) => Persist (ViaSerializeAs a) where+  put (MkViaSerializeAs x) = put (castPut x)   {-# INLINE put #-}-  get = getLE @Word32 >>= fmap LittleEndian . reinterpretCastGet+  unsafePut (MkViaSerializeAs x) = unsafePut (castPut x)+  {-# INLINE unsafePut #-}+  get = MkViaSerializeAs . castGet <$> get   {-# INLINE get #-}+  unsafeGet = MkViaSerializeAs . castGet <$> unsafeGet+  {-# INLINE unsafeGet #-} -instance Persist (BigEndian Float) where-  put x = reinterpretCastPut (unBE x) >>= putBE @Word32-  {-# INLINE put #-}-  get = getBE @Word32 >>= fmap BigEndian . reinterpretCastGet-  {-# INLINE get #-}+deriving via (ViaSerializeAs Word) instance HasEndianness Word+deriving via (ViaSerializeAs Int) instance HasEndianness Int+deriving via (ViaSerializeAs Word) instance Persist Word+deriving via (ViaSerializeAs Int) instance Persist Int -instance Persist Float where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+class ReinterpretAs a where+  type ReinterpretTarget a -instance Persist (LittleEndian Word) where-  put = put . fmap (fromIntegral @_ @Word64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word64) <$!> get-  {-# INLINE get #-}+newtype ViaReinterpretAs a = MkViaReinterpretAs a+  deriving (Eq, Ord, Show) -instance Persist (BigEndian Word) where-  put = put . fmap (fromIntegral @_ @Word64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Word64) <$!> get-  {-# INLINE get #-}+instance+  forall a b.+  (ReinterpretAs a, Storable a, Storable b, HasEndianness b, b ~ ReinterpretTarget a) =>+  HasEndianness (ViaReinterpretAs a)+  where+  unsafePutLE (MkViaReinterpretAs x) = reinterpretCastPut x >>= unsafePutLE @b+  {-# INLINE unsafePutLE #-}+  unsafePutBE (MkViaReinterpretAs x) = reinterpretCastPut x >>= unsafePutBE @b+  {-# INLINE unsafePutBE #-}+  unsafeGetLE = MkViaReinterpretAs <$> (unsafeGetLE @(ReinterpretTarget a) >>= reinterpretCastGet)+  {-# INLINE unsafeGetLE #-}+  unsafeGetBE = MkViaReinterpretAs <$> (unsafeGetBE @(ReinterpretTarget a) >>= reinterpretCastGet)+  {-# INLINE unsafeGetBE #-}+  endiannessSize = endiannessSize @b -instance Persist Word where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+instance ReinterpretAs Double where+  type ReinterpretTarget Double = Word64 -instance Persist (LittleEndian Int) where-  put = put . fmap (fromIntegral @_ @Int64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Int64) <$!> get-  {-# INLINE get #-}+instance ReinterpretAs Float where+  type ReinterpretTarget Float = Word32 -instance Persist (BigEndian Int) where-  put = put . fmap (fromIntegral @_ @Int64)-  {-# INLINE put #-}-  get = fmap (fromIntegral @Int64) <$!> get-  {-# INLINE get #-}+deriving via (ViaReinterpretAs Double) instance HasEndianness Double+deriving via (ViaReinterpretAs Float) instance HasEndianness Float -instance Persist Int where-  put = putLE-  {-# INLINE put #-}-  get = getLE-  {-# INLINE get #-}+deriving via (LittleEndian Double) instance Persist Double+deriving via (LittleEndian Float) instance Persist Float  instance Persist Integer where   put n = do@@ -715,14 +738,16 @@  unroll :: (Integral a, Bits a) => a -> [Word8] unroll = unfoldr step-  where step 0 = Nothing-        step i = Just (fromIntegral i, i `unsafeShiftR` 8)+ where+  step 0 = Nothing+  step i = Just (fromIntegral i, i `unsafeShiftR` 8)  roll :: (Integral a, Bits a) => [Word8] -> a roll = foldr unstep 0-  where unstep b a = a `unsafeShiftL` 8 .|. fromIntegral b+ where+  unstep b a = a `unsafeShiftL` 8 .|. fromIntegral b -instance Persist a => Persist (Ratio a) where+instance (Persist a) => Persist (Ratio a) where   put (n :% d) = put n *> put d   {-# INLINE put #-} @@ -735,49 +760,76 @@  -- Char is serialized as UTF-8 instance Persist Char where-  put a | c <= 0x7f     = put (fromIntegral c :: Word8)-        | c <= 0x7ff    = do put (0xc0 .|. y)-                             put (0x80 .|. z)-        | c <= 0xffff   = do put (0xe0 .|. x)-                             put (0x80 .|. y)-                             put (0x80 .|. z)-        | c <= 0x10ffff = do put (0xf0 .|. w)-                             put (0x80 .|. x)-                             put (0x80 .|. y)-                             put (0x80 .|. z)-        | otherwise = error "Not a valid Unicode code point"-    where-      c = ord a-      z, y, x, w :: Word8-      z = fromIntegral (c                 .&. 0x3f)-      y = fromIntegral (unsafeShiftR c 6  .&. 0x3f)-      x = fromIntegral (unsafeShiftR c 12 .&. 0x3f)-      w = fromIntegral (unsafeShiftR c 18 .&. 0x7)+  put a+    | c <= 0x7f = grow 1 >> unsafePut a+    | c <= 0x7ff = grow 2 >> unsafePut a+    | c <= 0xffff = grow 3 >> unsafePut a+    | c <= 0x10ffff = grow 4 >> unsafePut a+    | otherwise = error "Not a valid Unicode code point"+   where+    c = ord a   {-# INLINE put #-} +  unsafePut a+    | c <= 0x7f = unsafePut (fromIntegral c :: Word8)+    | c <= 0x7ff = do+        unsafePut (0xc0 .|. y)+        unsafePut (0x80 .|. z)+    | c <= 0xffff = do+        unsafePut (0xe0 .|. x)+        unsafePut (0x80 .|. y)+        unsafePut (0x80 .|. z)+    | c <= 0x10ffff = do+        unsafePut (0xf0 .|. w)+        unsafePut (0x80 .|. x)+        unsafePut (0x80 .|. y)+        unsafePut (0x80 .|. z)+    | otherwise = error "Not a valid Unicode code point"+   where+    c = ord a+    z, y, x, w :: Word8+    z = fromIntegral (c .&. 0x3f)+    y = fromIntegral (unsafeShiftR c 6 .&. 0x3f)+    x = fromIntegral (unsafeShiftR c 12 .&. 0x3f)+    w = fromIntegral (unsafeShiftR c 18 .&. 0x7)+  {-# INLINE unsafePut #-}+   get = do     let byte = fromIntegral <$!> get @Word8         shiftL6 = flip unsafeShiftL 6     w <- byte-    r <- if | w < 0x80  -> pure w-            | w < 0xe0  -> do-                x <- xor 0x80 <$!> byte-                pure $ x .|. shiftL6 (xor 0xc0 w)-            | w < 0xf0  -> do-                x <- xor 0x80 <$!> byte-                y <- xor 0x80 <$!> byte-                pure $ y .|. shiftL6 (x .|. shiftL6-                                       (xor 0xe0 w))-            | otherwise -> do-                x <- xor 0x80 <$!> byte-                y <- xor 0x80 <$!> byte-                z <- xor 0x80 <$!> byte-                pure $ z .|. shiftL6 (y .|. shiftL6-                                       (x .|. shiftL6 (xor 0xf0 w)))-    if r <= 0x10FFFF then-      pure $ unsafeChr r-    else-      failGet CharException "Invalid character"+    r <-+      if+        | w < 0x80 -> pure w+        | w < 0xe0 -> do+            x <- xor 0x80 <$!> byte+            pure $ x .|. shiftL6 (xor 0xc0 w)+        | w < 0xf0 -> do+            x <- xor 0x80 <$!> byte+            y <- xor 0x80 <$!> byte+            pure $+              y+                .|. shiftL6+                  ( x+                      .|. shiftL6+                        (xor 0xe0 w)+                  )+        | otherwise -> do+            x <- xor 0x80 <$!> byte+            y <- xor 0x80 <$!> byte+            z <- xor 0x80 <$!> byte+            pure $+              z+                .|. shiftL6+                  ( y+                      .|. shiftL6+                        (x .|. shiftL6 (xor 0xf0 w))+                  )+    if r <= 0x10FFFF+      then+        pure $ unsafeChr r+      else+        failGet CharException "Invalid character"   {-# INLINE get #-}  instance Persist Text where@@ -791,60 +843,105 @@ instance Persist Bool instance Persist Ordering instance (Persist a) => Persist (Maybe a)-instance Persist e => Persist (T.Tree e)+instance (Persist e) => Persist (T.Tree e) instance (Persist a, Persist b) => Persist (Either a b)-instance (Persist a, Persist b) => Persist (a,b)-instance (Persist a, Persist b, Persist c) => Persist (a,b,c)-instance (Persist a, Persist b, Persist c, Persist d)-        => Persist (a,b,c,d)-instance (Persist a, Persist b, Persist c, Persist d, Persist e)-        => Persist (a,b,c,d,e)-instance (Persist a, Persist b, Persist c, Persist d, Persist e-         , Persist f)-        => Persist (a,b,c,d,e,f)-instance (Persist a, Persist b, Persist c, Persist d, Persist e-         , Persist f, Persist g)-        => Persist (a,b,c,d,e,f,g)-instance Persist a => Persist (M.Dual a)+instance (Persist a, Persist b) => Persist (a, b)+instance (Persist a, Persist b, Persist c) => Persist (a, b, c)+instance+  (Persist a, Persist b, Persist c, Persist d) =>+  Persist (a, b, c, d)+instance+  (Persist a, Persist b, Persist c, Persist d, Persist e) =>+  Persist (a, b, c, d, e)+instance+  ( Persist a+  , Persist b+  , Persist c+  , Persist d+  , Persist e+  , Persist f+  ) =>+  Persist (a, b, c, d, e, f)+instance+  ( Persist a+  , Persist b+  , Persist c+  , Persist d+  , Persist e+  , Persist f+  , Persist g+  ) =>+  Persist (a, b, c, d, e, f, g)+instance (Persist a) => Persist (M.Dual a) instance Persist M.All instance Persist M.Any-instance Persist a => Persist (M.Sum a)-instance Persist a => Persist (M.Product a)-instance Persist a => Persist (M.First a)-instance Persist a => Persist (M.Last a)+instance (Persist a) => Persist (M.Sum a)+instance (Persist a) => Persist (M.Product a)+instance (Persist a) => Persist (M.First a)+instance (Persist a) => Persist (M.Last a) --- | Persist a list in the following format:---   Word64 (little endian format)---   element 1---   ...---   element n-instance Persist a => Persist [a] where-    put l = do-      put $ length l-      mapM_ put l-    {-# INLINE put #-}+{- | Persist a list in the following format:+  Word64 (little endian format)+  element 1+  ...+  element n+-}+instance (Persist a) => Persist [a] where+  put l = do+    sizeHandle <- reserveSize @Word64+    go sizeHandle 0 l+   where+    go sizeHandle !n [] = resolveSizeLE sizeHandle n+    go sizeHandle !n (x : rest) = put x >> go sizeHandle (n + 1) rest+  {-# INLINE put #-} -    get = go [] =<< get @Word64-      where go as 0 = pure $! reverse as-            go as i = do x <- get-                         x `seq` go (x:as) (i - 1)-    {-# INLINE get #-}+  get = go [] =<< get @Word64+   where+    go as 0 = pure $! reverse as+    go as i = do+      x <- get+      x `seq` go (x : as) (i - 1)+  {-# INLINE get #-}  instance Persist ByteString where   put s = do-    put $ B.length s-    putByteString s+    let lengthSize = fromIntegral (endiannessSize @Int)+    grow (B.length s + lengthSize)+    unsafePut s+  {-# INLINE put #-}++  unsafePut s = do+    unsafePut $ B.length s+    unsafePutByteString s+  {-# INLINE unsafePut #-}+   get = get >>= getByteString+  {-# INLINE get #-}  instance Persist L.ByteString where-  put = put . L.toStrict+  put s = do+    let lengthSize = fromIntegral (endiannessSize @Int64)+    grow (fromIntegral $ L.length s + lengthSize)+    unsafePut s+  {-# INLINE put #-}++  unsafePut s = do+    unsafePut $ L.length s+    forM_ (L.toChunks s) unsafePutByteString+  {-# INLINE unsafePut #-}+   get = L.fromStrict <$!> get+  {-# INLINE get #-}  instance Persist S.ShortByteString where   put s = do+    let lengthSize = fromIntegral (endiannessSize @Int)+    grow (S.length s + lengthSize)+    unsafePut s++  unsafePut s = do     let n = S.length s-    put n-    grow n+    unsafePut n     Put $ \_ p -> do       S.copyToPtr s 0 p n       pure $! p `plusPtr` n :!: ()@@ -867,25 +964,25 @@   put = put . toList   get = fromList <$!> get -instance Persist e => Persist (NonEmpty e) where+instance (Persist e) => Persist (NonEmpty e) where   put = put . toList   {-# INLINE put #-}   get = fromList <$!> get   {-# INLINE get #-} -instance Persist e => Persist (IntMap e) where+instance (Persist e) => Persist (IntMap e) where   put = put . toList   {-# INLINE put #-}   get = fromList <$!> get   {-# INLINE get #-} -instance Persist e => Persist (Seq e) where+instance (Persist e) => Persist (Seq e) where   put = put . toList   {-# INLINE put #-}   get = fromList <$!> get   {-# INLINE get #-} -type family SumArity (a :: * -> *) :: Nat where+type family SumArity (a :: Type -> Type) :: Nat where   SumArity (C1 c a) = 1   SumArity (x :+: y) = SumArity x + SumArity y @@ -895,19 +992,19 @@ class GPersistGet f where   gget :: Get (f a) -instance GPersistPut f => GPersistPut (M1 i c f) where+instance (GPersistPut f) => GPersistPut (M1 i c f) where   gput = gput . unM1   {-# INLINE gput #-} -instance GPersistGet f => GPersistGet (M1 i c f) where+instance (GPersistGet f) => GPersistGet (M1 i c f) where   gget = fmap M1 gget   {-# INLINE gget #-} -instance Persist a => GPersistPut (K1 i a) where+instance (Persist a) => GPersistPut (K1 i a) where   gput = put . unK1   {-# INLINE gput #-} -instance Persist a => GPersistGet (K1 i a) where+instance (Persist a) => GPersistGet (K1 i a) where   gget = fmap K1 get   {-# INLINE gget #-} @@ -935,35 +1032,50 @@   gget = (:*:) <$!> gget <*> gget   {-# INLINE gget #-} -instance (SumArity (a :+: b) <= 255, GPersistPutSum 0 (a :+: b)) => GPersistPut (a :+: b) where+instance (FitsInByte (SumArity (a :+: b)), GPersistPutSum 0 (a :+: b)) => GPersistPut (a :+: b) where   gput x = gputSum x (Proxy :: Proxy 0)   {-# INLINE gput #-} -instance (SumArity (a :+: b) <= 255, GPersistGetSum 0 (a :+: b)) => GPersistGet (a :+: b) where+instance (FitsInByte (SumArity (a :+: b)), GPersistGetSum 0 (a :+: b)) => GPersistGet (a :+: b) where   gget = do     tag <- get     ggetSum tag (Proxy :: Proxy 0)   {-# INLINE gget #-} -class KnownNat n => GPersistPutSum (n :: Nat) (f :: * -> *) where+type FitsInByte n = FitsInByteResult (n <=? 255)++type family FitsInByteResult (b :: Bool) :: Constraint where+  FitsInByteResult 'True = ()+  FitsInByteResult 'False =+    TypeErrorMessage+      "Generic deriving of Persist instances can only be used on datatypes with fewer than 256 constructors."++type family TypeErrorMessage (a :: Symbol) :: Constraint where+  TypeErrorMessage a = TypeError ('Text a)++class (KnownNat n) => GPersistPutSum (n :: Nat) (f :: Type -> Type) where   gputSum :: f p -> Proxy n -> Put () -class KnownNat n => GPersistGetSum (n :: Nat) (f :: * -> *) where+class (KnownNat n) => GPersistGetSum (n :: Nat) (f :: Type -> Type) where   ggetSum :: Word8 -> Proxy n -> Get (f p) -instance (GPersistPutSum n a, GPersistPutSum (n + SumArity a) b, KnownNat n)-         => GPersistPutSum n (a :+: b) where+instance+  (GPersistPutSum n a, GPersistPutSum (n + SumArity a) b, KnownNat n) =>+  GPersistPutSum n (a :+: b)+  where   gputSum (L1 l) _ = gputSum l (Proxy :: Proxy n)   gputSum (R1 r) _ = gputSum r (Proxy :: Proxy (n + SumArity a))   {-# INLINE gputSum #-} -instance (GPersistGetSum n a, GPersistGetSum (n + SumArity a) b, KnownNat n)-         => GPersistGetSum n (a :+: b) where+instance+  (GPersistGetSum n a, GPersistGetSum (n + SumArity a) b, KnownNat n) =>+  GPersistGetSum n (a :+: b)+  where   ggetSum tag proxyL     | tag < sizeL = L1 <$!> ggetSum tag proxyL     | otherwise = R1 <$!> ggetSum tag (Proxy :: Proxy (n + SumArity a))-    where-      sizeL = fromInteger (natVal (Proxy :: Proxy (n + SumArity a)))+   where+    sizeL = fromInteger (natVal (Proxy :: Proxy (n + SumArity a)))   {-# INLINE ggetSum #-}  instance (GPersistPut a, KnownNat n) => GPersistPutSum n (C1 c a) where@@ -977,8 +1089,8 @@     | tag == cur = gget     | tag > cur = fail "Sum tag invalid"     | otherwise = fail "Implementation error"-    where-      cur = fromInteger (natVal (Proxy :: Proxy n))+   where+    cur = fromInteger (natVal (Proxy :: Proxy n))   {-# INLINE ggetSum #-}  -- | Ensure that @n@ bytes are available. Fails if fewer than @n@ bytes are available.@@ -997,10 +1109,11 @@   Get $ \_ p -> pure $! p `plusPtr` n :!: () {-# INLINE skip #-} --- | Get the number of remaining unparsed bytes.  Useful for checking whether--- all input has been consumed.+{- | Get the number of remaining unparsed bytes.  Useful for checking whether+all input has been consumed.+-} remaining :: Get Int-remaining = Get $ \e p -> pure $! p :!: geEnd e `minusPtr` p+remaining = Get $ \e p -> pure $! p :!: e.end `minusPtr` p {-# INLINE remaining #-}  -- -- | Succeed if end of input reached.@@ -1014,24 +1127,121 @@ getBytes :: Int -> Get ByteString getBytes n = do   ensure n-  Get $ \e p -> pure $! p `plusPtr` n :!: B.PS (geBuf e) (p `minusPtr` geBegin e) n+  Get $ \e p -> pure $! p `plusPtr` n :!: B.PS e.buf (p `minusPtr` e.begin) n {-# INLINE getBytes #-} --- | An efficient 'get' method for strict ByteStrings. Fails if fewer--- than @n@ bytes are left in the input. This function creates a fresh--- copy of the underlying bytes.+{- | An efficient 'get' method for strict ByteStrings. Fails if fewer+than @n@ bytes are left in the input. This function creates a fresh+copy of the underlying bytes.+-} getByteString :: Int -> Get ByteString getByteString n = B.copy <$!> getBytes n {-# INLINE getByteString #-} +{- | An efficient 'get' method to apply a recursive 'get' to a substring of+known length.+-}+getPrefix :: Int -> Get a -> Get a+getPrefix prefixLength baseGet = do+  ensure prefixLength+  unsafeGetPrefix prefixLength baseGet+ runPut :: Put a -> ByteString runPut = snd . evalPut {-# INLINE runPut #-} +runPutLazy :: Put a -> L.ByteString+runPutLazy = snd . evalPutLazy+{-# INLINE runPutLazy #-}+ putByteString :: ByteString -> Put ()-putByteString (B.PS b o n) = do-  grow n+putByteString bs = do+  grow (B.length bs)+  unsafePutByteString bs++unsafePutByteString :: ByteString -> Put ()+unsafePutByteString (B.PS b o n) = do   Put $ \_ p -> do-    withForeignPtr b $ \q -> B.memcpy p (q `plusPtr` o) n+    withForeignPtr b $ \q -> copyBytes p (q `plusPtr` o) n     pure $! p `plusPtr` n :!: () {-# INLINE putByteString #-}++{- | Reserve a length value that can be filled in later. The length+  value itself must have a fixed size.+-}+reserveSize :: forall a. (HasEndianness a) => Put (PutSize a)+reserveSize = do+  grow sizeSize+  doWrite+ where+  sizeSize = fromIntegral $ endiannessSize @a+  doWrite = Put $ \e p -> do+    let p' = p `plusPtr` sizeSize+    (c :| _) <- readIORef e.chunks+    pure $!+      p'+        :!: PutSize+          { sizePtr = p+          , sizeStart = p'+          , chunkStart = c.begin+          }++{- | Backpatch a computed length value, excluding the bytes for the length+  itself.+-}+resolveSizeExclusive :: forall a. (Integral a, HasEndianness a) => (a -> Put ()) -> PutSize a -> Put ()+resolveSizeExclusive putter PutSize {..} = Put $ \e p -> do+  writeSize <- computeSize e chunkStart sizeStart p+  _ <- (putter writeSize).unPut e sizePtr+  pure $ p :!: ()++resolveSizeInclusive :: forall a. (Integral a, HasEndianness a) => (a -> Put ()) -> PutSize a -> Put ()+resolveSizeInclusive putter PutSize {..} = Put $ \e p -> do+  writeSize <- computeSize e chunkStart sizePtr p+  _ <- (putter writeSize).unPut e sizePtr+  pure $ p :!: ()++resolveSize :: forall a. (Integral a, HasEndianness a) => (a -> Put ()) -> PutSize a -> a -> Put ()+resolveSize putter PutSize {..} manualSize = Put $ \e p -> do+  _ <- (putter manualSize).unPut e sizePtr+  pure $ p :!: ()++computeSize ::+  forall a.+  (Integral a, HasEndianness a) =>+  PutEnv ->+  Ptr Word8 ->+  Ptr Word8 ->+  Ptr Word8 ->+  IO a+computeSize env chunkStartPtr basePtr finalPtr = do+  (chunk :| chunks) <- readIORef env.chunks+  if chunkStartPtr == chunk.begin+    then pure . fromIntegral $! finalPtr `minusPtr` basePtr+    else pure $ loop chunks (finalPtr `minusPtr` chunk.begin)+ where+  loop :: [Chunk] -> Int -> a+  loop [] !_acc = throw PutSizeMissingStartChunk+  loop (chunk : _) !acc+    | chunk.begin == chunkStartPtr =+        fromIntegral $ acc + (chunk.end `minusPtr` basePtr)+  loop (chunk : rest) !acc =+    loop rest (acc + (chunk.end `minusPtr` chunk.begin))++resolveSizeExclusiveBE :: (Integral a, HasEndianness a) => PutSize a -> Put ()+resolveSizeExclusiveBE = resolveSizeExclusive unsafePutBE++resolveSizeExclusiveLE :: (Integral a, HasEndianness a) => PutSize a -> Put ()+resolveSizeExclusiveLE = resolveSizeExclusive unsafePutLE++resolveSizeInclusiveBE :: (Integral a, HasEndianness a) => PutSize a -> Put ()+resolveSizeInclusiveBE = resolveSizeInclusive unsafePutBE++resolveSizeInclusiveLE :: (Integral a, HasEndianness a) => PutSize a -> Put ()+resolveSizeInclusiveLE = resolveSizeInclusive unsafePutLE++resolveSizeLE :: (Integral a, HasEndianness a) => PutSize a -> a -> Put()+resolveSizeLE = resolveSize unsafePutLE++resolveSizeBE :: (Integral a, HasEndianness a) => PutSize a -> a -> Put()+resolveSizeBE = resolveSize unsafePutBE

@@ -1,56 +1,79 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-} -module Data.Persist.Internal (-      (:!:)(..)+module Data.Persist.Internal+  ( (:!:) (..)+     -- * The Get type-    , Get(..)-    , GetEnv(..)-    , GetException(..)-    , getOffset-    , failGet-    , runGet-    , runGetIO+  , Get (..)+  , GetEnv (..)+  , GetException (..)+  , getOffset+  , failGet+  , runGet+  , runGetIO+  , unsafeGetPrefix      -- * The Put type-    , Put(..)-    , PutEnv(..)-    , Chunk(..)-    , evalPut-    , evalPutIO-    , grow-) where+  , Put (..)+  , PutEnv (..)+  , PutException (..)+  , Chunk (..)+  , evalPut+  , evalPutStrictIO+  , evalPutLazy+  , evalPutLazyIO+  , grow +    -- * Size reservations+  , PutSize (..)+  ) where+ import Control.Exception import Control.Monad+import qualified Control.Monad.Fail as Fail import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy.Internal as BL+#if MIN_VERSION_base(4,20,0) import Data.Foldable (foldlM)+#else+import Data.Foldable (foldl', foldlM)+#endif import Data.IORef-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Word-import Foreign (ForeignPtr, Ptr, plusPtr, minusPtr,-                withForeignPtr, mallocBytes, free, allocaBytes)+import Foreign+  ( ForeignPtr+  , Ptr+  , allocaBytes+  , finalizerFree+  , free+  , mallocBytes+  , minusPtr+  , newForeignPtr+  , plusPtr+  , reallocBytes+  , withForeignPtr+  )+import Foreign.Marshal.Utils (copyBytes) import System.IO.Unsafe-import qualified Control.Monad.Fail as Fail-import qualified Data.ByteString.Internal as B  #include "MachDeps.h" @@ -58,19 +81,19 @@ infixl 2 :!:  data GetEnv = GetEnv-  { geBuf   :: !(ForeignPtr Word8)-  , geBegin :: !(Ptr Word8)-  , geEnd   :: !(Ptr Word8)-  , geTmp   :: !(Ptr Word8)+  { buf :: !(ForeignPtr Word8)+  , begin :: {-# UNPACK #-} !(Ptr Word8)+  , end :: {-# UNPACK #-} !(Ptr Word8)+  , tmp :: {-# UNPACK #-} !(Ptr Word8)   }  newtype Get a = Get-  { unGet :: GetEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a)+  { unGet :: GetEnv -> Ptr Word8 -> IO (Ptr Word8 :!: a)   }  instance Functor Get where   fmap f m = Get $ \e p -> do-    p' :!: x <- unGet m e p+    p' :!: x <- m.unGet e p     pure $! p' :!: f x   {-# INLINE fmap #-} @@ -79,8 +102,8 @@   {-# INLINE pure #-}    f <*> a = Get $ \e p -> do-    p' :!: f' <- unGet f e p-    p'' :!: a' <- unGet a e p'+    p' :!: f' <- f.unGet e p+    p'' :!: a' <- a.unGet e p'     pure $! p'' :!: f' a'   {-# INLINE (<*>) #-} @@ -91,8 +114,8 @@  instance Monad Get where   m >>= f = Get $ \e p -> do-    p' :!: x <- unGet m e p-    unGet (f x) e p'+    p' :!: x <- m.unGet e p+    (f x).unGet e p'   {-# INLINE (>>=) #-}  #if !MIN_VERSION_base(4,11,0)@@ -109,12 +132,18 @@  instance Exception GetException +data PutException+  = PutSizeMissingStartChunk+  deriving (Eq, Show)++instance Exception PutException+ instance Fail.MonadFail Get where   fail msg = failGet GenericGetException ("Failed reading: " <> msg)   {-# INLINE fail #-}  getOffset :: Get Int-getOffset = Get $ \e p -> pure $! p :!: (p `minusPtr` (geBegin e))+getOffset = Get $ \e p -> pure $! p :!: (p `minusPtr` e.begin) {-# INLINE getOffset #-}  failGet :: (Int -> String -> GetException) -> String -> Get a@@ -124,35 +153,45 @@  runGetIO :: Get a -> ByteString -> IO a runGetIO m s = run-  where run = withForeignPtr buf $ \p -> allocaBytes 8 $ \t -> do-          let env = GetEnv { geBuf = buf, geBegin = p, geEnd = p `plusPtr` (pos + len), geTmp = t }-          _ :!: r <- unGet m env (p `plusPtr` pos)-          pure r-        (B.PS buf pos len) = s+ where+  run = withForeignPtr buf $ \p -> allocaBytes 8 $ \t -> do+    let env = GetEnv {buf, begin = p, end = p `plusPtr` (pos + len), tmp = t}+    _ :!: r <- m.unGet env (p `plusPtr` pos)+    pure r+  (B.PS buf pos len) = s  -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> ByteString -> Either String a-runGet m s = unsafePerformIO $ catch (Right <$!> (runGetIO m s)) handler-  where handler (e :: GetException) = pure $ Left $ displayException e+runGet m s = unsafePerformIO $ catch (Right <$!> runGetIO m s) handler+ where+  handler (e :: GetException) = pure $ Left $ displayException e {-# NOINLINE runGet #-} +unsafeGetPrefix :: Int -> Get a -> Get a+unsafeGetPrefix prefixLength baseGet = Get $ \env p -> do+  let p' = p `plusPtr` prefixLength+      env' = (\GetEnv {..} -> GetEnv {end = p', ..}) env+  _ :!: r <- baseGet.unGet env' p+  pure $ p' :!: r+{-# INLINE unsafeGetPrefix #-}+ data Chunk = Chunk-  { chkBegin :: !(Ptr Word8)-  , chkEnd   :: !(Ptr Word8)+  { begin :: {-# UNPACK #-} !(Ptr Word8)+  , end :: {-# UNPACK #-} !(Ptr Word8)   }  data PutEnv = PutEnv-  { peChks :: !(IORef (NonEmpty Chunk))-  , peEnd  :: !(IORef (Ptr Word8))-  , peTmp  :: !(Ptr Word8)+  { chunks :: !(IORef (NonEmpty Chunk))+  , end :: !(IORef (Ptr Word8))+  , tmp :: {-# UNPACK #-} !(Ptr Word8)   }  newtype Put a = Put-  { unPut :: PutEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a) }+  {unPut :: PutEnv -> Ptr Word8 -> IO (Ptr Word8 :!: a)}  instance Functor Put where   fmap f m = Put $ \e p -> do-    p' :!: x <- unPut m e p+    p' :!: x <- m.unPut e p     pure $! p' :!: f x   {-# INLINE fmap #-} @@ -161,8 +200,8 @@   {-# INLINE pure #-}    f <*> a = Put $ \e p -> do-    p' :!: f' <- unPut f e p-    p'' :!: a' <- unPut a e p'+    p' :!: f' <- f.unPut e p+    p'' :!: a' <- a.unPut e p'     pure $! p'' :!: f' a'   {-# INLINE (<*>) #-} @@ -173,10 +212,16 @@  instance Monad Put where   m >>= f = Put $ \e p -> do-    p' :!: x <- unPut m e p-    unPut (f x) e p'+    p' :!: x <- m.unPut e p+    (f x).unPut e p'   {-# INLINE (>>=) #-} +data PutSize a = PutSize+  { sizePtr :: !(Ptr Word8)+  , sizeStart :: !(Ptr Word8)+  , chunkStart :: !(Ptr Word8)+  }+ minChunkSize :: Int minChunkSize = 0x10000 {-# INLINE minChunkSize #-}@@ -193,47 +238,100 @@ grow n   | n < 0 = error "grow: negative length"   | otherwise = Put $ \e p -> do-      end <- readIORef (peEnd e)-      if end `minusPtr` p >= n then-        pure $! p :!: ()-      else-        doGrow e p n+      end <- readIORef e.end+      if end `minusPtr` p >= n+        then+          pure $! p :!: ()+        else+          doGrow e p n {-# INLINE grow #-} -doGrow :: PutEnv -> Ptr Word8 -> Int -> IO ((Ptr Word8) :!: ())+doGrow :: PutEnv -> Ptr Word8 -> Int -> IO (Ptr Word8 :!: ()) doGrow e p n = do   k <- newChunk n-  modifyIORef' (peChks e) $ \case-    (c:|cs) -> k :| c { chkEnd = p } : cs-  writeIORef (peEnd e) (chkEnd k)-  pure $! chkBegin k :!: ()+  modifyIORef' e.chunks $ \case+    (c :| cs) ->+      let !c' = (\Chunk {..} -> Chunk {end = p, ..}) c+       in k :| c' : cs+  writeIORef e.end $! k.end+  pure $! k.begin :!: () {-# NOINLINE doGrow #-}  chunksLength :: [Chunk] -> Int-chunksLength = foldr (\c s -> s + chkEnd c `minusPtr` chkBegin c) 0+chunksLength = foldl' (\s c -> s + c.end `minusPtr` c.begin) 0 {-# INLINE chunksLength #-}  catChunks :: [Chunk] -> IO ByteString catChunks chks = B.create (chunksLength chks) $ \p ->-  void $ foldlM (\q c -> do-                    let n = chkEnd c `minusPtr` chkBegin c-                    B.memcpy q (chkBegin c) n-                    free $ chkBegin c-                    pure (q `plusPtr` n)) p $ reverse chks+  void+    $ foldlM+      ( \q c -> do+          let n = c.end `minusPtr` c.begin+          copyBytes q c.begin n+          free c.begin+          pure (q `plusPtr` n)+      )+      p+    $ reverse chks {-# INLINE catChunks #-} -evalPutIO :: Put a -> IO (a, ByteString)-evalPutIO p = do+evalPutIO :: Put a -> (a -> NonEmpty Chunk -> IO (a, b)) -> IO (a, b)+evalPutIO p chunkConsumer = do   k <- newChunk 0-  chks <- newIORef (k:|[])-  end <- newIORef (chkEnd k)-  p' :!: r <- allocaBytes 8 $ \t ->-    unPut p PutEnv { peChks = chks, peEnd = end, peTmp = t } (chkBegin k)-  cs <- readIORef chks-  s <- case cs of-    (x:|xs) -> catChunks $ x { chkEnd = p' } : xs-  pure (r, s)+  chunks <- newIORef (k :| [])+  curEnd <- newIORef k.end+  p' :!: r <- allocaBytes 8 $ \tmp ->+    p.unPut PutEnv {chunks, end = curEnd, tmp} k.begin+  cs <- readIORef chunks+  case cs of+    (x :| xs) -> do+      let !x' = (\Chunk {..} -> Chunk {end = p', ..}) x+      chunkConsumer r (x' :| xs)+{-# INLINE evalPutIO #-} +evalPutStrictIO :: Put a -> IO (a, ByteString)+evalPutStrictIO p = evalPutIO p chunkHandler+ where+  chunkHandler r cs = do+    s <- case cs of+      (x :| []) -> singleChunk x+      (x :| xs) -> catChunks (x : xs)+    pure (r, s)+  singleChunk Chunk {..} = do+    case end `minusPtr` begin of+      0 -> do+        free begin+        pure B.empty+      newSize -> do+        newPtr <- reallocBytes begin newSize+        foreignNewPtr <- newForeignPtr finalizerFree newPtr+        pure $ B.BS foreignNewPtr newSize+{-# INLINE evalPutStrictIO #-}++evalPutLazyIO :: Put a -> IO (a, BL.ByteString)+evalPutLazyIO p = evalPutIO p chunkHandler+ where+  chunkHandler r cs = do+    s <- case cs of+      (x :| xs) -> foldlM makeLBSChunk BL.Empty (x : xs)+    pure (r, s)+  makeLBSChunk :: BL.ByteString -> Chunk -> IO BL.ByteString+  makeLBSChunk lbsTail Chunk {..} = do+    case end `minusPtr` begin of+      0 -> do+        free begin+        pure lbsTail+      newSize -> do+        newPtr <- reallocBytes begin newSize+        foreignNewPtr <- newForeignPtr finalizerFree newPtr+        let strictChunk = B.BS foreignNewPtr newSize+        pure $ BL.Chunk strictChunk lbsTail+{-# INLINE evalPutLazyIO #-}+ evalPut :: Put a -> (a, ByteString)-evalPut p = unsafePerformIO $ evalPutIO p+evalPut p = unsafePerformIO $ evalPutStrictIO p {-# NOINLINE evalPut #-}++evalPutLazy :: Put a -> (a, BL.ByteString)+evalPutLazy p = unsafePerformIO $ evalPutLazyIO p+{-# NOINLINE evalPutLazy #-}

@@ -1,102 +1,184 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}  ----------------------------------------------------------------------------------- |--- Module      :--- Copyright   : (c) Galois, Inc, 2009--- License     : BSD3------ Maintainer  : Trevor Elliott <trevor@galois.com>--- Stability   :--- Portability :---++{- |+Module      :+Copyright   : (c) Galois, Inc, 2009+License     : BSD3++Maintainer  : Trevor Elliott <trevor@galois.com>+Stability   :+Portability :+-} module RoundTrip where -import Numeric.Natural+import qualified Data.ByteString as BS (length)+import qualified Data.ByteString.Char8 as B8 (unpack)+import qualified Data.ByteString.Lazy as LBS (toStrict)+import Data.Int import Data.Persist import Data.Text (Text) import qualified Data.Text as T import Data.Word-import Data.Int-import System.Exit (ExitCode(..), exitSuccess, exitWith)-import Test.QuickCheck as QC--import Test.Framework (Test(),testGroup)+import Numeric.Natural+import System.Exit (ExitCode (..), exitSuccess, exitWith)+import Test.Framework (Test (), testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck as QC  roundTrip :: (Persist a, Eq a) => (a -> Put ()) -> Get a -> a -> Bool-roundTrip p g a = res == Right a-  where res = runGet (g <* eof) (runPut (p a))+roundTrip p g a = res == Right a && lazyRes == Right a+ where+  res = runGet (g <* eof) (runPut (p a))+  lazyRes = runGet (g <* eof) (LBS.toStrict (runPutLazy (p a))) +roundTripLengthInclusiveLE ::+  forall a l.+  (Persist a, Eq a, Eq l, HasEndianness l, Integral l) =>+  (a -> Put ()) ->+  Get a ->+  a ->+  Bool+roundTripLengthInclusiveLE putter getter val =+  result == Right (putterLength, val)+ where+  result = flip runGet putResult $ (,) <$> (getLE @l) <*> (getter <* eof)+  putResult = runPut $ do+    sizeSlot <- reserveSize @l+    putter val+    resolveSizeInclusiveLE sizeSlot+  putterLength = fromIntegral @_ @l $ BS.length putResult++roundTripLengthInclusiveBE ::+  forall a l.+  (Persist a, Eq a, Eq l, HasEndianness l, Integral l) =>+  (a -> Put ()) ->+  Get a ->+  a ->+  Bool+roundTripLengthInclusiveBE putter getter val =+  result == Right (putterLength, val)+ where+  result = flip runGet putResult $ (,) <$> (getBE @l) <*> (getter <* eof)+  putResult = runPut $ do+    sizeSlot <- reserveSize @l+    putter val+    resolveSizeInclusiveBE sizeSlot+  putterLength = fromIntegral @_ @l $ BS.length putResult++roundTripLengthExclusiveLE ::+  forall a l.+  (Persist a, Eq a, Eq l, HasEndianness l, Integral l) =>+  (a -> Put ()) ->+  Get a ->+  a ->+  Bool+roundTripLengthExclusiveLE putter getter val =+  result == Right (putterLength, val)+ where+  result = flip runGet putResult $ (,) <$> (getLE @l) <*> (getter <* eof)+  putResult = runPut $ do+    sizeSlot <- reserveSize @l+    putter val+    resolveSizeExclusiveLE sizeSlot+  putterLength = fromIntegral @_ @l $ BS.length putResult - endiannessSize @l++roundTripLengthExclusiveBE ::+  forall a l.+  (Persist a, Eq a, Eq l, HasEndianness l, Integral l) =>+  (a -> Put ()) ->+  Get a ->+  a ->+  Bool+roundTripLengthExclusiveBE putter getter val =+  result == Right (putterLength, val)+ where+  result = flip runGet putResult $ (,) <$> (getBE @l) <*> (getter <* eof)+  putResult = runPut $ do+    sizeSlot <- reserveSize @l+    putter val+    resolveSizeExclusiveBE sizeSlot+  putterLength = fromIntegral @_ @l $ BS.length putResult - endiannessSize @l+ -- | Did a call to 'quickCheckResult' succeed? isSuccess :: QC.Result -> Bool-isSuccess Success{} = True+isSuccess Success {} = True isSuccess _ = False  tests :: Test-tests  = testGroup "Round Trip"-  [ testProperty "Word8        Round Trip" $ roundTrip put (get @Word8)-  , testProperty "Word16       Round Trip" $ roundTrip put (get @Word16)-  , testProperty "Word16be     Round Trip" $ roundTrip putBE (getBE @Word16)-  , testProperty "Word16le     Round Trip" $ roundTrip putLE (getLE @Word16)-  , testProperty "Word16host   Round Trip" $ roundTrip putHE (getHE @Word16)-  , testProperty "Word32       Round Trip" $ roundTrip put (get @Word32)-  , testProperty "Word32be     Round Trip" $ roundTrip putBE (getBE @Word32)-  , testProperty "Word32le     Round Trip" $ roundTrip putLE (getLE @Word32)-  , testProperty "Word32host   Round Trip" $ roundTrip putHE (getHE @Word32)-  , testProperty "Word64       Round Trip" $ roundTrip put (get @Word64)-  , testProperty "Word64be     Round Trip" $ roundTrip putBE (getBE @Word64)-  , testProperty "Word64le     Round Trip" $ roundTrip putLE (getLE @Word64)-  , testProperty "Word64host   Round Trip" $ roundTrip putHE (getHE @Word64)--  , testProperty "Int8         Round Trip" $ roundTrip put (get @Int8)-  , testProperty "Int16        Round Trip" $ roundTrip put (get @Int16)-  , testProperty "Int16be      Round Trip" $ roundTrip putBE (getBE @Int16)-  , testProperty "Int16le      Round Trip" $ roundTrip putLE (getLE @Int16)-  , testProperty "Int16host    Round Trip" $ roundTrip putHE (getHE @Int16)-  , testProperty "Int32        Round Trip" $ roundTrip put (get @Int32)-  , testProperty "Int32be      Round Trip" $ roundTrip putBE (getBE @Int32)-  , testProperty "Int32le      Round Trip" $ roundTrip putLE (getLE @Int32)-  , testProperty "Int32host    Round Trip" $ roundTrip putHE (getHE @Int32)-  , testProperty "Int64        Round Trip" $ roundTrip put (get @Int64)-  , testProperty "Int64be      Round Trip" $ roundTrip putBE (getBE @Int64)-  , testProperty "Int64le      Round Trip" $ roundTrip putLE (getLE @Int64)-  , testProperty "Int64host    Round Trip" $ roundTrip putHE (getHE @Int64)--  , testProperty "Float        Round Trip" $ roundTrip put (get @Float)-  , testProperty "Floatbe      Round Trip" $ roundTrip putBE (getBE @Float)-  , testProperty "Floatle      Round Trip" $ roundTrip putLE (getLE @Float)-  , testProperty "Floathost    Round Trip" $ roundTrip putHE (getHE @Float)-  , testProperty "Double       Round Trip" $ roundTrip put (get @Double)-  , testProperty "Doublebe     Round Trip" $ roundTrip putBE (getBE @Double)-  , testProperty "Doublele     Round Trip" $ roundTrip putLE (getLE @Double)-  , testProperty "Doublehost   Round Trip" $ roundTrip putHE (getHE @Double)--  , testProperty "Char Round Trip"-    $ roundTrip put (get :: Get Char)-  , testProperty "String Round Trip"-    $ roundTrip put (get :: Get String)-  , testProperty "Text Round Trip"-    $ roundTrip put get . T.pack-  , testProperty "Integer Round Trip"-    $ roundTrip put (get :: Get Integer)-  , testProperty "Natural Round Trip"-    $ roundTrip put get . (fromInteger :: Integer -> Natural) . abs-  , testProperty "(Word8,Word8) Round Trip"-    $ roundTrip put (get :: Get (Word8, Word8))-  , testProperty "(Word8,Word16,Word32,Word64) Round Trip"-    $ roundTrip put (get :: Get (Word8, Word16, Word32, Word64))-  , testProperty "Complex Round Trip"-    $ roundTrip put (get :: Get (Either (Word8, Word8) (Word16, Either Int32 [String], Word64)))-  , testProperty "[Word8] Round Trip"-    $ roundTrip put (get :: Get [Word8])-  , testProperty "Bool Round Trip"-    $ roundTrip put (get :: Get Bool)-  , testProperty "Ordering Round Trip"-    $ roundTrip put (get :: Get Ordering)-  , testProperty "Maybe Word8 Round Trip"-    $ roundTrip put (get :: Get (Maybe Word8))-  , testProperty "Either Word8 Word16 Round Trip"-    $ roundTrip put (get :: Get (Either Word8 Word16))-  ]+tests =+  testGroup+    "Round Trip"+    [ testProperty "Word8        Round Trip" $ roundTrip put (get @Word8)+    , testProperty "Word16       Round Trip" $ roundTrip put (get @Word16)+    , testProperty "Word16be     Round Trip" $ roundTrip putBE (getBE @Word16)+    , testProperty "Word16le     Round Trip" $ roundTrip putLE (getLE @Word16)+    , testProperty "Word16host   Round Trip" $ roundTrip putHE (getHE @Word16)+    , testProperty "Word32       Round Trip" $ roundTrip put (get @Word32)+    , testProperty "Word32be     Round Trip" $ roundTrip putBE (getBE @Word32)+    , testProperty "Word32le     Round Trip" $ roundTrip putLE (getLE @Word32)+    , testProperty "Word32host   Round Trip" $ roundTrip putHE (getHE @Word32)+    , testProperty "Word64       Round Trip" $ roundTrip put (get @Word64)+    , testProperty "Word64be     Round Trip" $ roundTrip putBE (getBE @Word64)+    , testProperty "Word64le     Round Trip" $ roundTrip putLE (getLE @Word64)+    , testProperty "Word64host   Round Trip" $ roundTrip putHE (getHE @Word64)+    , testProperty "Int8         Round Trip" $ roundTrip put (get @Int8)+    , testProperty "Int16        Round Trip" $ roundTrip put (get @Int16)+    , testProperty "Int16be      Round Trip" $ roundTrip putBE (getBE @Int16)+    , testProperty "Int16le      Round Trip" $ roundTrip putLE (getLE @Int16)+    , testProperty "Int16host    Round Trip" $ roundTrip putHE (getHE @Int16)+    , testProperty "Int32        Round Trip" $ roundTrip put (get @Int32)+    , testProperty "Int32be      Round Trip" $ roundTrip putBE (getBE @Int32)+    , testProperty "Int32le      Round Trip" $ roundTrip putLE (getLE @Int32)+    , testProperty "Int32host    Round Trip" $ roundTrip putHE (getHE @Int32)+    , testProperty "Int64        Round Trip" $ roundTrip put (get @Int64)+    , testProperty "Int64be      Round Trip" $ roundTrip putBE (getBE @Int64)+    , testProperty "Int64le      Round Trip" $ roundTrip putLE (getLE @Int64)+    , testProperty "Int64host    Round Trip" $ roundTrip putHE (getHE @Int64)+    , testProperty "Float        Round Trip" $ roundTrip put (get @Float)+    , testProperty "Floatbe      Round Trip" $ roundTrip putBE (getBE @Float)+    , testProperty "Floatle      Round Trip" $ roundTrip putLE (getLE @Float)+    , testProperty "Floathost    Round Trip" $ roundTrip putHE (getHE @Float)+    , testProperty "Double       Round Trip" $ roundTrip put (get @Double)+    , testProperty "Doublebe     Round Trip" $ roundTrip putBE (getBE @Double)+    , testProperty "Doublele     Round Trip" $ roundTrip putLE (getLE @Double)+    , testProperty "Doublehost   Round Trip" $ roundTrip putHE (getHE @Double)+    , testProperty "Char Round Trip" $+        roundTrip put (get :: Get Char)+    , testProperty "String Round Trip" $+        roundTrip put (get :: Get String)+    , testProperty "Text Round Trip" $+        roundTrip put get . T.pack+    , testProperty "Integer Round Trip" $+        roundTrip put (get :: Get Integer)+    , testProperty "Natural Round Trip" $+        roundTrip put get . (fromInteger :: Integer -> Natural) . abs+    , testProperty "(Word8,Word8) Round Trip" $+        roundTrip put (get :: Get (Word8, Word8))+    , testProperty "(Word8,Word16,Word32,Word64) Round Trip" $+        roundTrip put (get :: Get (Word8, Word16, Word32, Word64))+    , testProperty "Complex Round Trip" $+        roundTrip put (get :: Get (Either (Word8, Word8) (Word16, Either Int32 [String], Word64)))+    , testProperty "[Word8] Round Trip" $+        roundTrip put (get :: Get [Word8])+    , testProperty "Bool Round Trip" $+        roundTrip put (get :: Get Bool)+    , testProperty "Ordering Round Trip" $+        roundTrip put (get :: Get Ordering)+    , testProperty "Maybe Word8 Round Trip" $+        roundTrip put (get :: Get (Maybe Word8))+    , testProperty "Either Word8 Word16 Round Trip" $+        roundTrip put (get :: Get (Either Word8 Word16))+    , testProperty "Sized LE Inclusive roundTrip for (Text,Text,Text) and Word64" $+        roundTripLengthInclusiveLE @_ @Word64 put get . (\(s1, s2, s3) -> (T.pack s1, T.pack s2, T.pack s3))+    , testProperty "Sized BE Inclusive roundTrip for (Text,Text,Text) and Word64" $+        roundTripLengthInclusiveBE @_ @Word64 put get . (\(s1, s2, s3) -> (T.pack s1, T.pack s2, T.pack s3))+    , testProperty "Sized LE Exclusive roundTrip for (Text,Text,Text) and Word64" $+        roundTripLengthExclusiveLE @_ @Word64 put get . (\(s1, s2, s3) -> (T.pack s1, T.pack s2, T.pack s3))+    , testProperty "Sized BE Exclusive roundTrip for (Text,Text,Text) and Word64" $+        roundTripLengthExclusiveBE @_ @Word64 put get . (\(s1, s2, s3) -> (T.pack s1, T.pack s2, T.pack s3))+    ]