dahdit 0.2.0 → 0.3.0

raw patch · 5 files changed

+343/−194 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• dahdit.cabal +1/−1
• src/Dahdit/Iface.hs +48/−5
• src/Dahdit/Mem.hs +63/−34
• src/Dahdit/Run.hs +38/−30
• test/Main.hs +193/−124

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           dahdit-version:        0.2.0+version:        0.3.0 synopsis:       Binary parsing and serialization with integrated size description:    Please see the README on GitHub at <https://github.com/ejconlon/dahdit#readme> category:       Data

@@ -2,16 +2,22 @@   ( BinaryTarget (..)   , getTarget   , putTarget+  , MutBinaryTarget (..)+  , mutPutTargetOffset+  , mutPutTarget   , decode   , decodeFile   , encode   , encodeFile+  , mutEncode   ) where +import Control.Monad.Primitive (PrimBase, PrimMonad (..))+import Control.Monad.ST (runST) import Dahdit.Binary (Binary (..)) import Dahdit.Free (Get, Put)-import Dahdit.Mem (allocArrayMem, allocPtrMem, freezeBSMem, freezeSBSMem, freezeVecMem, viewBSMem, viewSBSMem, viewVecMem)+import Dahdit.Mem (allocBAMem, allocPtrMem, freezeBAMem, freezeBSMem, freezeSBSMem, freezeVecMem, mutAllocBAMem, mutAllocVecMem, mutFreezeBAMem, mutFreezeVecMem, viewBSMem, viewSBSMem, viewVecMem) import Dahdit.Run (GetError, runCount, runGetInternal, runPutInternal) import Dahdit.Sizes (ByteCount (..), ByteSized (..)) import Data.ByteString (ByteString)@@ -19,13 +25,15 @@ import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS import Data.Coerce (coerce)+import Data.Primitive.ByteArray (ByteArray, MutableByteArray, sizeofByteArray) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as VS+import Data.Vector.Storable.Mutable (MVector) import Data.Word (Word8)  -- | Abstracts over the sources we can read from / sinks we can render to. class BinaryTarget z where-  -- | Put an action to the sink with the given capacity.+  -- | Put an action to the sink with the given length.   -- Prefer 'putTarget' to safely count capacity, or use 'encode' to use byte size.   putTargetUnsafe :: Put -> ByteCount -> z @@ -41,6 +49,15 @@ putTarget :: BinaryTarget z => Put -> z putTarget p = putTargetUnsafe p (runCount p) +class MutBinaryTarget m z where+  mutPutTargetOffsetUnsafe :: ByteCount -> Put -> ByteCount -> z -> m ByteCount++mutPutTargetOffset :: MutBinaryTarget m z => ByteCount -> Put -> z -> m ByteCount+mutPutTargetOffset off p = mutPutTargetOffsetUnsafe off p (runCount p)++mutPutTarget :: MutBinaryTarget m z => Put -> z -> m ByteCount+mutPutTarget = mutPutTargetOffset 0+ instance BinaryTarget ShortByteString where   getTargetOffset = runGetSBS   putTargetUnsafe = runPutSBS@@ -49,10 +66,20 @@   getTargetOffset = runGetBS   putTargetUnsafe = runPutBS +instance BinaryTarget ByteArray where+  getTargetOffset = runGetBA+  putTargetUnsafe = runPutBA+ instance BinaryTarget (Vector Word8) where   getTargetOffset = runGetVec   putTargetUnsafe = runPutVec +instance (PrimBase m, s ~ PrimState m) => MutBinaryTarget m (MutableByteArray s) where+  mutPutTargetOffsetUnsafe = runMutPutBA++instance (PrimBase m, s ~ PrimState m) => MutBinaryTarget m (MVector s Word8) where+  mutPutTargetOffsetUnsafe = runMutPutVec+ -- | Decode a value from a source returning a result and consumed byte count. decode :: (Binary a, BinaryTarget z) => z -> (Either GetError a, ByteCount) decode = getTarget get@@ -69,6 +96,13 @@ encodeFile :: (Binary a, ByteSized a) => a -> FilePath -> IO () encodeFile a = runPutFile (put a) (byteSize a) +-- | Encode a value to a mutable buffer, returning number of bytes filled.+mutEncode :: (Binary a, ByteSized a, MutBinaryTarget m z) => a -> z -> m ByteCount+mutEncode a = mutPutTargetOffsetUnsafe 0 (put a) (byteSize a)++runGetBA :: ByteCount -> Get a -> ByteArray -> (Either GetError a, ByteCount)+runGetBA off act ba = runGetInternal off act (coerce (sizeofByteArray ba)) ba+ runGetSBS :: ByteCount -> Get a -> ShortByteString -> (Either GetError a, ByteCount) runGetSBS off act sbs = runGetInternal off act (coerce (BSS.length sbs)) (viewSBSMem sbs) @@ -83,16 +117,25 @@   bs <- BS.readFile fp   pure (runGetBS 0 act bs) +runPutBA :: Put -> ByteCount -> ByteArray+runPutBA act len = runST (runPutInternal 0 act len allocBAMem freezeBAMem)+ runPutSBS :: Put -> ByteCount -> ShortByteString-runPutSBS act cap = runPutInternal act cap allocArrayMem freezeSBSMem+runPutSBS act len = runST (runPutInternal 0 act len allocBAMem freezeSBSMem)  runPutBS :: Put -> ByteCount -> ByteString-runPutBS act cap = runPutInternal act cap allocPtrMem freezeBSMem+runPutBS act len = runST (runPutInternal 0 act len allocPtrMem freezeBSMem)  runPutVec :: Put -> ByteCount -> Vector Word8-runPutVec act cap = runPutInternal act cap allocPtrMem freezeVecMem+runPutVec act len = runST (runPutInternal 0 act len allocPtrMem freezeVecMem)  runPutFile :: Put -> ByteCount -> FilePath -> IO () runPutFile act cap fp =   let bs = runPutBS act cap   in  BS.writeFile fp bs++runMutPutBA :: PrimBase m => ByteCount -> Put -> ByteCount -> MutableByteArray (PrimState m) -> m ByteCount+runMutPutBA off act len marr = runPutInternal off act len (mutAllocBAMem marr) mutFreezeBAMem++runMutPutVec :: PrimBase m => ByteCount -> Put -> ByteCount -> MVector (PrimState m) Word8 -> m ByteCount+runMutPutVec off act len mvec = runPutInternal off act len (mutAllocVecMem mvec) mutFreezeVecMem

@@ -7,16 +7,21 @@   , viewVecMem   , WriteMem (..)   , writeSBSMem-  , allocArrayMem+  , allocBAMem   , allocPtrMem+  , freezeBAMem   , freezeSBSMem   , freezeBSMem   , freezeVecMem+  , mutAllocBAMem+  , mutFreezeBAMem+  , mutAllocVecMem+  , mutFreezeVecMem   ) where -import Control.Monad.ST (ST, runST)-import Control.Monad.ST.Unsafe (unsafeIOToST)+import Control.Monad.Primitive (PrimMonad (..), unsafeIOToPrim)+import Control.Monad.ST (runST) import Dahdit.LiftedPrim (LiftedPrim (..), setByteArrayLifted) import Dahdit.Proxy (proxyFor) import Dahdit.Sizes (ByteCount (..), staticByteSize)@@ -26,10 +31,11 @@ import qualified Data.ByteString.Unsafe as BSU import Data.Coerce (coerce) import Data.Foldable (for_)-import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray, cloneByteArray, copyByteArray, copyByteArrayToPtr, freezeByteArray, newByteArray, unsafeFreezeByteArray)+import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray, cloneByteArray, copyByteArray, copyByteArrayToPtr, freezeByteArray, newByteArray, sizeofMutableByteArray, unsafeFreezeByteArray) import Data.Primitive.Ptr (copyPtrToMutableByteArray)-import Data.Vector.Storable (Vector)+import Data.Vector.Storable (MVector, Vector) import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Storable.Mutable as VSM import Data.Word (Word8) import Foreign.ForeignPtr (newForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)@@ -76,58 +82,81 @@   let (fp, _) = VS.unsafeToForeignPtr0 vec   in  unsafeForeignPtrToPtr fp -class WriteMem q where-  writeMemInBytes :: LiftedPrim a => a -> q s -> ByteCount -> ST s ()-  copyArrayMemInBytes :: ByteArray -> ByteCount -> ByteCount -> q s -> ByteCount -> ST s ()-  setMemInBytes :: LiftedPrim a => ByteCount -> a -> q s -> ByteCount -> ST s ()-  releaseMem :: q s -> Maybe (IO ())+mutViewVecMem :: MVector s Word8 -> Ptr Word8+mutViewVecMem mvec =+  let (fp, _) = VSM.unsafeToForeignPtr0 mvec+  in  unsafeForeignPtrToPtr fp -instance WriteMem MutableByteArray where+class PrimMonad m => WriteMem q m where+  writeMemInBytes :: LiftedPrim a => a -> q (PrimState m) -> ByteCount -> m ()+  copyArrayMemInBytes :: ByteArray -> ByteCount -> ByteCount -> q (PrimState m) -> ByteCount -> m ()+  setMemInBytes :: LiftedPrim a => ByteCount -> a -> q (PrimState m) -> ByteCount -> m ()++instance PrimMonad m => WriteMem MutableByteArray m where   writeMemInBytes val mem off = writeArrayLiftedInBytes mem off val   copyArrayMemInBytes arr arrOff arrLen mem off = copyByteArray mem (coerce off) arr (coerce arrOff) (coerce arrLen)   setMemInBytes len val mem off = setByteArrayLifted mem off len val-  releaseMem = const Nothing -copyPtr :: ByteArray -> ByteCount -> ByteCount -> Ptr Word8 -> ByteCount -> ST s ()+copyPtr :: PrimMonad m => ByteArray -> ByteCount -> ByteCount -> Ptr Word8 -> ByteCount -> m () copyPtr arr arrOff arrLen ptr off =   let wptr = coerce (plusPtr ptr (coerce off)) :: Ptr Word8   in  copyByteArrayToPtr wptr arr (coerce arrOff) (coerce arrLen) -setPtr :: LiftedPrim a => ByteCount -> a -> Ptr Word8 -> ByteCount -> ST s ()+setPtr :: (PrimMonad m, LiftedPrim a) => ByteCount -> a -> Ptr Word8 -> ByteCount -> m () setPtr len val ptr off = do   let elemSize = staticByteSize (proxyFor val)       elemLen = div (coerce len) elemSize   for_ [0 .. elemLen - 1] $ \pos ->     writePtrLiftedInBytes ptr (off + pos * elemSize) val -instance WriteMem IxPtr where+instance PrimMonad m => WriteMem IxPtr m where   writeMemInBytes val mem off = writePtrLiftedInBytes (unIxPtr mem) off val   copyArrayMemInBytes arr arrOff arrLen = copyPtr arr arrOff arrLen . unIxPtr   setMemInBytes len val = setPtr len val . unIxPtr-  releaseMem = Just . free . unIxPtr -writeSBSMem :: WriteMem q => ShortByteString -> ByteCount -> q s -> ByteCount -> ST s ()+writeSBSMem :: WriteMem q m => ShortByteString -> ByteCount -> q (PrimState m) -> ByteCount -> m () writeSBSMem (SBS harr) = copyArrayMemInBytes (ByteArray harr) 0 -guardedFreeze :: (q s -> ByteCount -> ST s z) -> q s -> ByteCount -> ByteCount -> ST s z-guardedFreeze freeze arr len off =-  -- This is a sanity check - if it goes wrong then there's a bug in the library-  if off /= len-    then error ("Invalid put length: (given " ++ show len ++ ", used " ++ show off ++ ")")-    else freeze arr len+freezeBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ByteArray+freezeBAMem marr (ByteCount startOff) (ByteCount endOff) =+  if startOff == 0 && endOff == sizeofMutableByteArray marr+    then unsafeFreezeByteArray marr+    else freezeByteArray marr startOff (endOff - startOff) -freezeSBSMem :: MutableByteArray s -> ByteCount -> ByteCount -> ST s ShortByteString-freezeSBSMem marr cap len = fmap (\(ByteArray harr) -> SBS harr) (if cap == len then unsafeFreezeByteArray marr else freezeByteArray marr 0 (coerce len))+freezeSBSMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ShortByteString+freezeSBSMem marr startOff endOff = fmap (\(ByteArray harr) -> SBS harr) (freezeBAMem marr startOff endOff) -freezeBSMem :: IxPtr s -> ByteCount -> ByteCount -> ST s ByteString-freezeBSMem (IxPtr ptr) _ len =-  unsafeIOToST (BSU.unsafePackCStringFinalizer ptr (coerce len) (free ptr))+freezeBSMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m ByteString+freezeBSMem (IxPtr ptr) startOff endOff =+  unsafeIOToPrim $+    BSU.unsafePackCStringFinalizer+      (plusPtr ptr (unByteCount startOff))+      (unByteCount (endOff - startOff))+      (free ptr) -freezeVecMem :: IxPtr s -> ByteCount -> ByteCount -> ST s (Vector Word8)-freezeVecMem (IxPtr ptr) _ len = unsafeIOToST (fmap (\fp -> VS.unsafeFromForeignPtr0 fp (coerce len)) (newForeignPtr finalizerFree ptr))+freezeVecMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m (Vector Word8)+freezeVecMem (IxPtr ptr) _ len = unsafeIOToPrim (fmap (\fp -> VS.unsafeFromForeignPtr0 fp (coerce len)) (newForeignPtr finalizerFree ptr)) -allocPtrMem :: ByteCount -> ST s (IxPtr s)-allocPtrMem = fmap IxPtr . unsafeIOToST . callocBytes . coerce+allocPtrMem :: PrimMonad m => ByteCount -> ByteCount -> m (IxPtr (PrimState m), Maybe (IO ()))+allocPtrMem off len = do+  let cap = off + len+  ptr <- unsafeIOToPrim (callocBytes (unByteCount cap))+  pure (IxPtr ptr, Just (free ptr)) -allocArrayMem :: ByteCount -> ST s (MutableByteArray s)-allocArrayMem = newByteArray . coerce+allocBAMem :: PrimMonad m => ByteCount -> ByteCount -> m (MutableByteArray (PrimState m), Maybe (IO ()))+allocBAMem off len = do+  let cap = off + len+  arr <- newByteArray (unByteCount cap)+  pure (arr, Nothing)++mutAllocBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m (MutableByteArray (PrimState m), Maybe (IO ()))+mutAllocBAMem u _ _ = pure (u, Nothing)++mutFreezeBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ByteCount+mutFreezeBAMem _ _ = pure++mutAllocVecMem :: PrimMonad m => MVector (PrimState m) Word8 -> ByteCount -> ByteCount -> m (IxPtr (PrimState m), Maybe (IO ()))+mutAllocVecMem u _ _ = pure (IxPtr (mutViewVecMem u), Nothing)++mutFreezeVecMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m ByteCount+mutFreezeVecMem _ _ = pure

@@ -1,3 +1,5 @@+{-# LANGUAGE UndecidableInstances #-}+ module Dahdit.Run   ( GetError (..)   , prettyGetError@@ -12,9 +14,9 @@ import Control.Monad (replicateM_, unless) import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) import Control.Monad.Free.Church (F (..))+import Control.Monad.Primitive (PrimBase, PrimMonad (..), unsafeIOToPrim, unsafePrimToIO) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) import Control.Monad.ST.Strict (ST, runST)-import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Control.Monad.State.Strict (MonadState, State, runState) import qualified Control.Monad.State.Strict as State import Control.Monad.Trans (lift)@@ -65,6 +67,7 @@ import Data.Foldable (for_, toList) import Data.Int (Int8) import Data.Maybe (fromJust)+import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar, writeMutVar) import Data.STRef.Strict (STRef, newSTRef, readSTRef, writeSTRef) import qualified Data.Sequence as Seq import Data.Word (Word8)@@ -253,7 +256,7 @@ -- Put unsafe:  data PutEnv s q = PutEnv-  { peOff :: !(STRef s ByteCount)+  { peOff :: !(MutVar s ByteCount)   -- ^ Offset in bytes from start of buffer   , peCap :: !ByteCount   -- ^ Capacity of buffer segment@@ -261,33 +264,35 @@   -- ^ Destination buffer   } -newPutEnv :: ByteCount -> q s -> ST s (PutEnv s q)-newPutEnv cap mem = do-  offRef <- newSTRef 0+newPutEnv :: PrimMonad m => ByteCount -> ByteCount -> q (PrimState m) -> m (PutEnv (PrimState m) q)+newPutEnv off cap mem = do+  offRef <- newMutVar off   pure (PutEnv offRef cap mem) -newtype PutEff s q a = PutEff {unPutEff :: ReaderT (PutEnv s q) (ST s) a}-  deriving newtype (Functor, Applicative, Monad, MonadReader (PutEnv s q))+newtype PutEff q m a = PutEff {unPutEff :: ReaderT (PutEnv (PrimState m) q) m a}+  deriving newtype (Functor, Applicative, Monad) -runPutEff :: PutEff s q a -> PutEnv s q -> ST s a+deriving newtype instance (Monad m, s ~ PrimState m) => MonadReader (PutEnv s q) (PutEff q m)++runPutEff :: PutEff q m a -> PutEnv (PrimState m) q -> m a runPutEff act = runReaderT (unPutEff act) -stPutEff :: ST s a -> PutEff s q a+stPutEff :: Monad m => m a -> PutEff q m a stPutEff = PutEff . lift -newtype PutRun s q a = PutRun {unPutRun :: FreeT PutF (PutEff s q) a}+newtype PutRun q m a = PutRun {unPutRun :: FreeT PutF (PutEff q m) a}   deriving newtype (Functor, Applicative, Monad) -writeBytes :: ByteCount -> (q s -> ByteCount -> ST s ()) -> PutEff s q ()+writeBytes :: PrimMonad m => ByteCount -> (q (PrimState m) -> ByteCount -> m ()) -> PutEff q m () writeBytes bc f = do   PutEnv offRef _ mem <- ask   stPutEff $ do-    off <- readSTRef offRef+    off <- readMutVar offRef     f mem off     let newOff = off + bc-    writeSTRef offRef newOff+    writeMutVar offRef newOff -writeStaticSeq :: WriteMem q => PutStaticSeqF (PutEff s q a) -> PutEff s q a+writeStaticSeq :: WriteMem q m => PutStaticSeqF (PutEff q m a) -> PutEff q m a writeStaticSeq (PutStaticSeqF n mz p s k) = do   for_ (take (coerce n) (toList s)) $ \a -> do     mkPutEff (p a)@@ -297,7 +302,7 @@     replicateM_ (coerce n - e) q   k -writeStaticArray :: WriteMem q => PutStaticArrayF (PutEff s q a) -> PutEff s q a+writeStaticArray :: WriteMem q m => PutStaticArrayF (PutEff q m a) -> PutEff q m a writeStaticArray psa@(PutStaticArrayF needElems mz a@(LiftedPrimArray ba) k) = do   let elemSize = putStaticArrayElemSize psa       haveElems = sizeofLiftedPrimArray a@@ -312,7 +317,7 @@       Just z -> writeBytes extraBc (setMemInBytes extraBc z)   k -execPutRun :: WriteMem q => PutF (PutEff s q a) -> PutEff s q a+execPutRun :: WriteMem q m => PutF (PutEff q m a) -> PutEff q m a execPutRun = \case   PutFWord8 x k -> writeBytes 1 (writeMemInBytes x) *> k   PutFInt8 x k -> writeBytes 1 (writeMemInBytes x) *> k@@ -344,24 +349,25 @@     writeBytes bc (copyArrayMemInBytes barr 0 bc) *> k   PutFStaticHint (PutStaticHintF _ p k) -> mkPutEff p *> k -runPutRun :: WriteMem q => PutRun s q a -> PutEnv s q -> ST s a+runPutRun :: WriteMem q m => PutRun q m a -> PutEnv (PrimState m) q -> m a runPutRun = runPutEff . iterPutRun -iterPutRun :: WriteMem q => PutRun s q a -> PutEff s q a+iterPutRun :: WriteMem q m => PutRun q m a -> PutEff q m a iterPutRun act = iterT execPutRun (unPutRun act) -mkPutRun :: PutM a -> PutRun s q a+mkPutRun :: Monad m => PutM a -> PutRun q m a mkPutRun (PutM (F w)) = PutRun (w pure wrap) -mkPutEff :: WriteMem q => PutM a -> PutEff s q a+mkPutEff :: WriteMem q m => PutM a -> PutEff q m a mkPutEff = iterPutRun . mkPutRun -runPutUnsafe :: WriteMem q => Put -> ByteCount -> q s -> ST s ByteCount-runPutUnsafe act len mem = do+runPutUnsafe :: WriteMem q m => ByteCount -> Put -> ByteCount -> q (PrimState m) -> m ByteCount+runPutUnsafe off act len mem = do   let eff = mkPutRun act-  st@(PutEnv offRef _ _) <- newPutEnv len mem+      cap = off + len+  st@(PutEnv offRef _ _) <- newPutEnv off cap mem   runPutRun eff st-  readSTRef offRef+  readMutVar offRef  -- Count: @@ -428,9 +434,11 @@  -- Put safe: -runPutInternal :: WriteMem q => Put -> ByteCount -> (forall s. ByteCount -> ST s (q s)) -> (forall s. q s -> ByteCount -> ByteCount -> ST s z) -> z-runPutInternal act cap mkMem useMem = runST $ do-  mem <- mkMem cap-  case releaseMem mem of-    Nothing -> runPutUnsafe act cap mem >>= useMem mem cap-    Just rel -> unsafeIOToST (onException (unsafeSTToIO (runPutUnsafe act cap mem >>= useMem mem cap)) rel)+primOnExc :: PrimBase m => m a -> Maybe (IO ()) -> m a+primOnExc prim = maybe prim $ \onExc ->+  unsafeIOToPrim (onException (unsafePrimToIO prim) onExc)++runPutInternal :: (PrimBase m, WriteMem q m) => ByteCount -> Put -> ByteCount -> (ByteCount -> ByteCount -> m (q (PrimState m), Maybe (IO ()))) -> (q (PrimState m) -> ByteCount -> ByteCount -> m z) -> m z+runPutInternal off act len mkMem useMem = do+  (mem, rel) <- mkMem off len+  primOnExc (runPutUnsafe off act len mem >>= useMem mem off) rel

@@ -1,5 +1,6 @@ module Main (main) where +import Control.Monad.Primitive (PrimState) import Dahdit   ( Binary (..)   , BinaryTarget (..)@@ -23,6 +24,7 @@   , Int64BE   , Int64LE   , LiftedPrimArray (..)+  , MutBinaryTarget (..)   , Proxy (..)   , Put   , ShortByteString@@ -74,6 +76,8 @@   , getWord8   , lengthLiftedPrimArray   , liftedPrimArrayFromList+  , mutPutTarget+  , mutPutTargetOffset   , putByteArray   , putByteString   , putDoubleBE@@ -107,15 +111,18 @@   ) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC+import Data.ByteString.Short (ShortByteString (..)) import qualified Data.ByteString.Short as BSS import Data.Coerce (coerce) import Data.Int (Int16, Int32, Int64, Int8)-import Data.Primitive.ByteArray (byteArrayFromList)+import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray, byteArrayFromList, freezeByteArray, newByteArray, sizeofMutableByteArray) import Data.Proxy (asProxyTypeOf) import qualified Data.Sequence as Seq import Data.ShortWord (Int24, Word24) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as VS+import Data.Vector.Storable.Mutable (MVector)+import qualified Data.Vector.Storable.Mutable as VSM import Data.Word (Word16, Word32, Word64, Word8) import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Test.Tasty (TestTree, defaultMain, testGroup)@@ -137,6 +144,18 @@   initSource = VS.fromList   consumeSink = VS.toList +class MutBinaryTarget IO u => MutCaseTarget u where+  newSink :: ByteCount -> IO u+  freezeSink :: u -> IO [Word8]++instance (s ~ PrimState IO) => MutCaseTarget (MutableByteArray s) where+  newSink = newByteArray . unByteCount+  freezeSink u = fmap (\(ByteArray arr) -> BSS.unpack (SBS arr)) (freezeByteArray u 0 (sizeofMutableByteArray u))++instance (s ~ PrimState IO) => MutCaseTarget (MVector s Word8) where+  newSink = VSM.new . unByteCount+  freezeSink = fmap consumeSink . VS.freeze+ data DynFoo = DynFoo !Word8 !Word16LE   deriving stock (Eq, Show, Generic)   deriving (ByteSized, Binary) via (ViaGeneric DynFoo)@@ -154,8 +173,11 @@ mkStaBytes :: String -> StaBytes mkStaBytes = StaticBytes . BSS.toShort . BSC.pack -runGetCase :: (Show a, Eq a, CaseTarget z) => Proxy z -> Get a -> Maybe (ByteCount, ByteCount, a) -> [Word8] -> IO ()-runGetCase p getter mayRes buf = do+data GetCase where+  GetCase :: (Show a, Eq a) => String -> Get a -> Maybe (ByteCount, ByteCount, a) -> [Word8] -> GetCase++runGetCase :: CaseTarget z => Proxy z -> GetCase -> TestTree+runGetCase p (GetCase name getter mayRes buf) = testCase name $ do   let src = initSource buf `asProxyTypeOf` p       totLen = coerce (length buf)       (result, actOff) = getTarget getter src@@ -168,18 +190,31 @@       actOff @?= expecOff       totLen - actOff @?= expecLeft -runPutCase :: CaseTarget z => Proxy z -> Put -> [Word8] -> IO ()-runPutCase p putter expecList = do-  let expecBc = coerce (length expecList)-      expecBs = expecList+data PutCase where+  PutCase :: String -> Put -> [Word8] -> PutCase++runPutCase :: CaseTarget z => Proxy z -> PutCase -> TestTree+runPutCase p (PutCase name putter expecBs) = testCase name $ do+  let expecBc = coerce (length expecBs)       estBc = runCount putter   estBc @?= expecBc-  let actSink = putTargetUnsafe putter estBc `asProxyTypeOf` p+  let actSink = putTargetUnsafe putter expecBc `asProxyTypeOf` p       actBs = consumeSink actSink       actBc = coerce (length actBs)   actBs @?= expecBs   actBc @?= expecBc +mutRunPutCase :: MutCaseTarget z => Proxy z -> PutCase -> TestTree+mutRunPutCase p (PutCase name putter expecBs) = testCase name $ do+  let expecBc = coerce (length expecBs)+  actSink <- fmap (`asProxyTypeOf` p) (newSink expecBc)+  endOff <- mutPutTarget putter actSink+  endOff @?= expecBc+  actBs <- freezeSink actSink+  let actBc = coerce (length actBs)+  actBs @?= expecBs+  actBc @?= expecBc+ testByteSize :: TestTree testByteSize =   testGroup@@ -275,107 +310,109 @@     , testCase "StaBytes" (staticByteSize @StaBytes Proxy @?= 2)     ] +getCases :: [GetCase]+getCases =+  [ GetCase "Word8 zero" getWord8 Nothing []+  , GetCase "Word8 one" getWord8 (Just (1, 0, 0x5D)) [0x5D]+  , GetCase "Word8 two" getWord8 (Just (1, 1, 0x5D)) [0x5D, 0xBB]+  , GetCase "Int8" getInt8 (Just (1, 0, 0x5D)) [0x5D]+  , GetCase "Word16LE zero" getWord16LE Nothing []+  , GetCase "Word16LE one" getWord16LE Nothing [0x5D]+  , GetCase "Word16LE two" getWord16LE (Just (2, 0, 0x5DEC)) [0xEC, 0x5D]+  , GetCase "Word16LE three" getWord16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "Int16LE" getInt16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "Word16BE" getWord16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB]+  , GetCase "Int16BE" getInt16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB]+  , GetCase "Word24LE" getWord24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Int24LE" getInt24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Word24BE" getWord24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D]+  , GetCase "Int24BE" getInt24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D]+  , GetCase "Word32LE" getWord32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Int32LE" getInt32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Word32BE" getWord32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD]+  , GetCase "Int32BE" getInt32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD]+  , GetCase "Word64LE" getWord64LE (Just (8, 0, 0x5DEC6EFD12345678)) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Word64BE" getWord64BE (Just (8, 0, 0x5DEC6EFD12345678)) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , GetCase "Int64LE" getInt64LE (Just (8, 0, 0x5DEC6EFD12345678)) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "Int64BE" getInt64BE (Just (8, 0, 0x5DEC6EFD12345678)) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , GetCase "FloatLE" getFloatLE (Just (4, 0, FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "FloatBE" getFloatBE (Just (4, 0, FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD]+  , GetCase "DoubleLE" getDoubleLE (Just (8, 0, DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "DoubleBE" getDoubleBE (Just (8, 0, DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , GetCase "ShortByteString" (getByteString 2) (Just (2, 1, BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D, 0xBB]+  , GetCase "Two Word8" ((,) <$> getWord8 <*> getWord8) (Just (2, 0, (0x5D, 0xBB))) [0x5D, 0xBB]+  , GetCase "Two Word16LE" ((,) <$> getWord16LE <*> getWord16LE) (Just (4, 0, (0x5DEC, 0x4020))) [0xEC, 0x5D, 0x20, 0x40]+  , GetCase "Seq" (getSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , GetCase "StaticSeq" (getStaticSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , GetCase "StaticArray" (getStaticArray @Word16LE 2) (Just (4, 0, liftedPrimArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , GetCase "DynFoo" (get @DynFoo) (Just (3, 0, DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D]+  , GetCase "StaFoo" (get @StaFoo) (Just (3, 0, StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D]+  , GetCase "getRemainingSize" getRemainingSize (Just (0, 3, 3)) [0xBB, 0xEC, 0x5D]+  , GetCase "getSkip" (getSkip 2) (Just (2, 1, ())) [0xBB, 0xEC, 0x5D]+  , GetCase "getLookAhead" (getLookAhead getWord16LE) (Just (0, 3, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "getExact eq" (getExact 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "getExact lt" (getExact 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB]+  , GetCase "getExact gt" (getExact 3 getWord16LE) Nothing [0xEC, 0x5D, 0xBB]+  , GetCase "getWithin eq" (getWithin 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "getWithin lt" (getWithin 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB]+  , GetCase "getWithin gt" (getWithin 3 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB]+  , GetCase "BoolByte True" (get @BoolByte) (Just (1, 0, BoolByte True)) [0x01]+  , GetCase "BoolByte False" (get @BoolByte) (Just (1, 0, BoolByte False)) [0x00]+  , GetCase "getByteArray" (getByteArray 3) (Just (3, 1, byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC, 0x5D]+  , GetCase "getLiftedPrimArray" (getLiftedPrimArray (Proxy :: Proxy Word16LE) 3) (Just (6, 1, liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00, 0x5D]+  , GetCase "StaBytes" (get @StaBytes) (Just (2, 1, mkStaBytes "hi")) [0x68, 0x69, 0x21]+  , GetCase "TagFoo (one)" (get @TagFoo) (Just (2, 0, TagFooOne 7)) [0x00, 0x07]+  , GetCase "TagFoo (two)" (get @TagFoo) (Just (3, 0, TagFooTwo 7)) [0x01, 0x07, 0x00]+  ]+ testGet :: CaseTarget z => String -> Proxy z -> TestTree-testGet n p =-  testGroup-    ("get (" ++ n ++ ")")-    [ testCase "Word8 zero" (runGetCase p getWord8 Nothing [])-    , testCase "Word8 one" (runGetCase p getWord8 (Just (1, 0, 0x5D)) [0x5D])-    , testCase "Word8 two" (runGetCase p getWord8 (Just (1, 1, 0x5D)) [0x5D, 0xBB])-    , testCase "Int8" (runGetCase p getInt8 (Just (1, 0, 0x5D)) [0x5D])-    , testCase "Word16LE zero" (runGetCase p getWord16LE Nothing [])-    , testCase "Word16LE one" (runGetCase p getWord16LE Nothing [0x5D])-    , testCase "Word16LE two" (runGetCase p getWord16LE (Just (2, 0, 0x5DEC)) [0xEC, 0x5D])-    , testCase "Word16LE three" (runGetCase p getWord16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "Int16LE" (runGetCase p getInt16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "Word16BE" (runGetCase p getWord16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB])-    , testCase "Int16BE" (runGetCase p getInt16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB])-    , testCase "Word24LE" (runGetCase p getWord24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int24LE" (runGetCase p getInt24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word24BE" (runGetCase p getWord24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D])-    , testCase "Int24BE" (runGetCase p getInt24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D])-    , testCase "Word32LE" (runGetCase p getWord32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int32LE" (runGetCase p getInt32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word32BE" (runGetCase p getWord32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Int32BE" (runGetCase p getInt32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Word64LE" (runGetCase p getWord64LE (Just (8, 0, 0x5DEC6EFD12345678)) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word64BE" (runGetCase p getWord64BE (Just (8, 0, 0x5DEC6EFD12345678)) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "Int64LE" (runGetCase p getInt64LE (Just (8, 0, 0x5DEC6EFD12345678)) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int64BE" (runGetCase p getInt64BE (Just (8, 0, 0x5DEC6EFD12345678)) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "FloatLE" (runGetCase p getFloatLE (Just (4, 0, FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "FloatBE" (runGetCase p getFloatBE (Just (4, 0, FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "DoubleLE" (runGetCase p getDoubleLE (Just (8, 0, DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "DoubleBE" (runGetCase p getDoubleBE (Just (8, 0, DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "ShortByteString" (runGetCase p (getByteString 2) (Just (2, 1, BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D, 0xBB])-    , testCase "Two Word8" (runGetCase p ((,) <$> getWord8 <*> getWord8) (Just (2, 0, (0x5D, 0xBB))) [0x5D, 0xBB])-    , testCase "Two Word16LE" (runGetCase p ((,) <$> getWord16LE <*> getWord16LE) (Just (4, 0, (0x5DEC, 0x4020))) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "Seq" (runGetCase p (getSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticSeq" (runGetCase p (getStaticSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticArray" (runGetCase p (getStaticArray @Word16LE 2) (Just (4, 0, liftedPrimArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "DynFoo" (runGetCase p (get @DynFoo) (Just (3, 0, DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "StaFoo" (runGetCase p (get @StaFoo) (Just (3, 0, StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "getRemainingSize" (runGetCase p getRemainingSize (Just (0, 3, 3)) [0xBB, 0xEC, 0x5D])-    , testCase "getSkip" (runGetCase p (getSkip 2) (Just (2, 1, ())) [0xBB, 0xEC, 0x5D])-    , testCase "getLookAhead" (runGetCase p (getLookAhead getWord16LE) (Just (0, 3, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getExact eq" (runGetCase p (getExact 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getExact lt" (runGetCase p (getExact 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getExact gt" (runGetCase p (getExact 3 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getWithin eq" (runGetCase p (getWithin 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getWithin lt" (runGetCase p (getWithin 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getWithin gt" (runGetCase p (getWithin 3 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "BoolByte True" (runGetCase p (get @BoolByte) (Just (1, 0, BoolByte True)) [0x01])-    , testCase "BoolByte False" (runGetCase p (get @BoolByte) (Just (1, 0, BoolByte False)) [0x00])-    , testCase "getByteArray" (runGetCase p (getByteArray 3) (Just (3, 1, byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "getLiftedPrimArray" (runGetCase p (getLiftedPrimArray (Proxy :: Proxy Word16LE) 3) (Just (6, 1, liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00, 0x5D])-    , testCase "StaBytes" (runGetCase p (get @StaBytes) (Just (2, 1, mkStaBytes "hi")) [0x68, 0x69, 0x21])-    , testCase "TagFoo (one)" (runGetCase p (get @TagFoo) (Just (2, 0, TagFooOne 7)) [0x00, 0x07])-    , testCase "TagFoo (two)" (runGetCase p (get @TagFoo) (Just (3, 0, TagFooTwo 7)) [0x01, 0x07, 0x00])-    ]+testGet n p = testGroup ("get (" ++ n ++ ")") (fmap (runGetCase p) getCases) +putCases :: [PutCase]+putCases =+  [ PutCase "Word8" (putWord8 0x5D) [0x5D]+  , PutCase "Int8" (putInt8 0x5D) [0x5D]+  , PutCase "Word16LE" (putWord16LE 0x5DEC) [0xEC, 0x5D]+  , PutCase "Int16LE" (putInt16LE 0x5DEC) [0xEC, 0x5D]+  , PutCase "Word16BE" (putWord16BE 0x5DEC) [0x5D, 0xEC]+  , PutCase "Int16BE" (putInt16BE 0x5DEC) [0x5D, 0xEC]+  , PutCase "Word24LE" (putWord24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC]+  , PutCase "Int24LE" (putInt24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC]+  , PutCase "Word24BE" (putWord24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD]+  , PutCase "Int24BE" (putInt24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD]+  , PutCase "Word32LE" (putWord32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "Int32LE" (putInt32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "Word32BE" (putWord32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD]+  , PutCase "Int32BE" (putInt32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD]+  , PutCase "Word64LE" (putWord64LE 0x5DEC6EFD12345678) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "Int64LE" (putInt64LE 0x5DEC6EFD12345678) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "Word64BE" (putWord64BE 0x5DEC6EFD12345678) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , PutCase "Int64BE" (putInt64BE 0x5DEC6EFD12345678) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , PutCase "FloatLE" (putFloatLE (FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "FloatBE" (putFloatBE (FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD]+  , PutCase "DoubleLE" (putDoubleLE (DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D]+  , PutCase "DoubleBE" (putDoubleBE (DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78]+  , PutCase "ShortByteString" (putByteString (BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D]+  , PutCase "Two Word8" (putWord8 0x5D *> putWord8 0xBB) [0x5D, 0xBB]+  , PutCase "Two Word16LE" (putWord16LE 0x5DEC *> putWord16LE 0x4020) [0xEC, 0x5D, 0x20, 0x40]+  , PutCase "Seq" (putSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , PutCase "StaticSeq" (putStaticSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , PutCase "StaticArray" (putStaticArray @Word16LE (liftedPrimArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40]+  , PutCase "DynFoo" (put (DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D]+  , PutCase "StaFoo" (put (StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D]+  , PutCase "BoolByte True" (put (BoolByte True)) [0x01]+  , PutCase "BoolByte False" (put (BoolByte False)) [0x00]+  , PutCase "putByteArray" (putByteArray (byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC]+  , PutCase "putLiftedPrimArray" (putLiftedPrimArray (liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00]+  , PutCase "StaBytes" (put (mkStaBytes "hi")) [0x68, 0x69]+  , PutCase "StaBytes (less)" (put (mkStaBytes "h")) [0x68, 0x00]+  , PutCase "StaBytes (more)" (put (mkStaBytes "hi!")) [0x68, 0x69]+  , PutCase "TagFoo (one)" (put (TagFooOne 7)) [0x00, 0x07]+  , PutCase "TagFoo (two)" (put (TagFooTwo 7)) [0x01, 0x07, 0x00]+  ]+ testPut :: CaseTarget z => String -> Proxy z -> TestTree-testPut n p =-  testGroup-    ("put (" ++ n ++ ")")-    [ testCase "Word8" (runPutCase p (putWord8 0x5D) [0x5D])-    , testCase "Int8" (runPutCase p (putInt8 0x5D) [0x5D])-    , testCase "Word16LE" (runPutCase p (putWord16LE 0x5DEC) [0xEC, 0x5D])-    , testCase "Int16LE" (runPutCase p (putInt16LE 0x5DEC) [0xEC, 0x5D])-    , testCase "Word16BE" (runPutCase p (putWord16BE 0x5DEC) [0x5D, 0xEC])-    , testCase "Int16BE" (runPutCase p (putInt16BE 0x5DEC) [0x5D, 0xEC])-    , testCase "Word24LE" (runPutCase p (putWord24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC])-    , testCase "Int24LE" (runPutCase p (putInt24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC])-    , testCase "Word24BE" (runPutCase p (putWord24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD])-    , testCase "Int24BE" (runPutCase p (putInt24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD])-    , testCase "Word32LE" (runPutCase p (putWord32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int32LE" (runPutCase p (putInt32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word32BE" (runPutCase p (putWord32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Int32BE" (runPutCase p (putInt32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Word64LE" (runPutCase p (putWord64LE 0x5DEC6EFD12345678) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int64LE" (runPutCase p (putInt64LE 0x5DEC6EFD12345678) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word64BE" (runPutCase p (putWord64BE 0x5DEC6EFD12345678) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "Int64BE" (runPutCase p (putInt64BE 0x5DEC6EFD12345678) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "FloatLE" (runPutCase p (putFloatLE (FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "FloatBE" (runPutCase p (putFloatBE (FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "DoubleLE" (runPutCase p (putDoubleLE (DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "DoubleBE" (runPutCase p (putDoubleBE (DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78])-    , testCase "ShortByteString" (runPutCase p (putByteString (BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D])-    , testCase "Two Word8" (runPutCase p (putWord8 0x5D *> putWord8 0xBB) [0x5D, 0xBB])-    , testCase "Two Word16LE" (runPutCase p (putWord16LE 0x5DEC *> putWord16LE 0x4020) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "Seq" (runPutCase p (putSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticSeq" (runPutCase p (putStaticSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticArray" (runPutCase p (putStaticArray @Word16LE (liftedPrimArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "DynFoo" (runPutCase p (put (DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "StaFoo" (runPutCase p (put (StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "BoolByte True" (runPutCase p (put (BoolByte True)) [0x01])-    , testCase "BoolByte False" (runPutCase p (put (BoolByte False)) [0x00])-    , testCase "putByteArray" (runPutCase p (putByteArray (byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC])-    , testCase "putLiftedPrimArray" (runPutCase p (putLiftedPrimArray (liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00])-    , testCase "StaBytes" (runPutCase p (put (mkStaBytes "hi")) [0x68, 0x69])-    , testCase "StaBytes (less)" (runPutCase p (put (mkStaBytes "h")) [0x68, 0x00])-    , testCase "StaBytes (more)" (runPutCase p (put (mkStaBytes "hi!")) [0x68, 0x69])-    , testCase "TagFoo (one)" (runPutCase p (put (TagFooOne 7)) [0x00, 0x07])-    , testCase "TagFoo (two)" (runPutCase p (put (TagFooTwo 7)) [0x01, 0x07, 0x00])-    ]+testPut n p = testGroup ("put (" ++ n ++ ")") (fmap (runPutCase p) putCases)  testLiftedPrimArray :: TestTree testLiftedPrimArray = testCase "liftedPrimArray" $ do@@ -384,8 +421,8 @@   sizeofLiftedPrimArray arr @?= 6   lengthLiftedPrimArray arr @?= 3 -testGetWithOffset :: CaseTarget z => String -> Proxy z -> TestTree-testGetWithOffset n p = testCase ("get with offset (" ++ n ++ ")") $ do+testGetOffset :: CaseTarget z => String -> Proxy z -> TestTree+testGetOffset n p = testCase ("get offset (" ++ n ++ ")") $ do   let buf = [0x12, 0x34, 0x56, 0x78]       src = initSource buf `asProxyTypeOf` p       (ez1, c1) = getTargetOffset 0 getWord8 src@@ -398,23 +435,55 @@   ez3 @?= Left (GetErrorParseNeed "Word16LE" 1 2)   c3 @?= 3 +testMutPut :: MutCaseTarget u => String -> Proxy u -> TestTree+testMutPut n p = testGroup ("mut put (" ++ n ++ ")") (fmap (mutRunPutCase p) putCases)++testMutPutOffset :: MutCaseTarget u => String -> Proxy u -> TestTree+testMutPutOffset n p = testCase ("mut put offset (" ++ n ++ ")") $ do+  u <- newSink 4+  c1 <- mutPutTargetOffset 0 (putWord8 0x12) u+  c1 @?= 1+  c2 <- mutPutTargetOffset 1 (putWord16LE 0x5634) u+  c2 @?= 3+  x <- freezeSink (u `asProxyTypeOf` p)+  x @?= [0x12, 0x34, 0x56, 0]+  pure ()++data TargetDef where+  TargetDef :: CaseTarget z => String -> Proxy z -> TargetDef++targets :: [TargetDef]+targets =+  [ TargetDef "ShortByteString" (Proxy :: Proxy ShortByteString)+  , TargetDef "ByteString" (Proxy :: Proxy ByteString)+  , TargetDef "Vector" (Proxy :: Proxy (Vector Word8))+  ]++data MutTargetDef where+  MutTargetDef :: MutCaseTarget u => String -> Proxy u -> MutTargetDef++mutTargets :: [MutTargetDef]+mutTargets =+  [ MutTargetDef "MutableByteArray" (Proxy :: Proxy (MutableByteArray (PrimState IO)))+  , MutTargetDef "MVector" (Proxy :: Proxy (MVector (PrimState IO) Word8))+  ]+ testDahdit :: TestTree-testDahdit =-  testGroup-    "Dahdit"-    [ testByteSize-    , testStaticByteSize-    , testGet "ShortByteString" (Proxy :: Proxy ShortByteString)-    , testGet "ByteString" (Proxy :: Proxy ByteString)-    , testGet "Vector" (Proxy :: Proxy (Vector Word8))-    , testPut "ShortByteString" (Proxy :: Proxy ShortByteString)-    , testPut "ByteString" (Proxy :: Proxy ByteString)-    , testPut "Vector" (Proxy :: Proxy (Vector Word8))-    , testLiftedPrimArray-    , testGetWithOffset "ShortByteString" (Proxy :: Proxy ShortByteString)-    , testGetWithOffset "ByteString" (Proxy :: Proxy ByteString)-    , testGetWithOffset "Vector" (Proxy :: Proxy (Vector Word8))-    ]+testDahdit = testGroup "Dahdit" trees+ where+  trees = baseTrees ++ targetTrees ++ mutTargetTrees+  baseTrees = [testByteSize, testStaticByteSize, testLiftedPrimArray]+  targetTrees =+    targets >>= \(TargetDef name prox) ->+      [ testGet name prox+      , testPut name prox+      , testGetOffset name prox+      ]+  mutTargetTrees =+    mutTargets >>= \(MutTargetDef name prox) ->+      [ testMutPut name prox+      , testMutPutOffset name prox+      ]  main :: IO () main = defaultMain testDahdit