diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -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. diff --git a/persist.cabal b/persist.cabal --- a/persist.cabal +++ b/persist.cabal @@ -1,71 +1,83 @@ -name: persist -version: 0.1.1.5 -license: BSD3 -license-file: LICENSE -author: Daniel Mendler , - Michael Sloan , - FP Complete, - Lennart Kolmodin , - Galois Inc., - Lemmih , - Bas van Dijk -maintainer: Daniel Mendler -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 , + Michael Sloan , + FP Complete, + Lennart Kolmodin , + Galois Inc., + Lemmih , + Bas van Dijk , + Kyle Butt +maintainer: Kyle Butt +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 diff --git a/src/Data/Persist.hs b/src/Data/Persist.hs --- a/src/Data/Persist.hs +++ b/src/Data/Persist.hs @@ -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 diff --git a/src/Data/Persist/Internal.hs b/src/Data/Persist/Internal.hs --- a/src/Data/Persist/Internal.hs +++ b/src/Data/Persist/Internal.hs @@ -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 #-} diff --git a/tests/RoundTrip.hs b/tests/RoundTrip.hs --- a/tests/RoundTrip.hs +++ b/tests/RoundTrip.hs @@ -1,102 +1,184 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -------------------------------------------------------------------------------- --- | --- Module : --- Copyright : (c) Galois, Inc, 2009 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- + +{- | +Module : +Copyright : (c) Galois, Inc, 2009 +License : BSD3 + +Maintainer : Trevor Elliott +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)) + ]