dahdit 0.1.4 → 0.2.0

raw patch · 19 files changed

+1967/−785 lines, 19 filesdep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

API changes (from Hackage documentation)

Files

• README.md +6/−7
• dahdit.cabal +8/−1
• src/Dahdit.hs +10/−6
• src/Dahdit/Binary.hs +189/−17
• src/Dahdit/BinaryRep.hs +8/−1
• src/Dahdit/Codec.hs +3/−3
• src/Dahdit/Fancy.hs +33/−32
• src/Dahdit/Free.hs +27/−8
• src/Dahdit/Funs.hs +113/−45
• src/Dahdit/Generic.hs +104/−2
• src/Dahdit/Iface.hs +98/−0
• src/Dahdit/Internal.hs +70/−15
• src/Dahdit/LiftedPrim.hs +290/−99
• src/Dahdit/LiftedPrimArray.hs +124/−0
• src/Dahdit/Mem.hs +133/−0
• src/Dahdit/Nums.hs +57/−121
• src/Dahdit/Run.hs +226/−258
• src/Dahdit/Sizes.hs +174/−61
• test/Main.hs +294/−109

@@ -2,16 +2,15 @@  Binary parsing and serialization with integrated size. +(dahs and dits are signal durations in Morse code)+ This differs from `binary` in a few ways: -* It is required that all types implementing `Binary` must also implement `ByteSized`.-* Known-statically-sized types can implement `StaticByteSized` for size speedups.+* It supports parsing from (or rendering into) pinned or unpinned memory.+* It uses `ByteArray` internally to avoid generating new or retaining references to old pinned memory. * Examining `Put` can yield required byte size without serializing.-* It uses `ShortByteString` to avoid pinned memory.-* It supports parsing `PrimArray` for fast copies of repeated chunks of primitive data. * Derivation uses `via` and not `anyclass` for better control of derived instances.+* Optionally, types implementing `Binary` can also implement or derive `ByteSized` for size calculation.+* Known-statically-sized types can implement `StaticByteSized` for size speedups. * Provides several additional types representing fixed-length strings or sequences (using `TypeLits`). -This generally works but should be considered experimental.--(dahs and dits are signal durations in Morse code)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           dahdit-version:        0.1.4+version:        0.2.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@@ -36,8 +36,11 @@       Dahdit.Free       Dahdit.Funs       Dahdit.Generic+      Dahdit.Iface       Dahdit.Internal       Dahdit.LiftedPrim+      Dahdit.LiftedPrimArray+      Dahdit.Mem       Dahdit.Nums       Dahdit.Proxy       Dahdit.Run@@ -64,6 +67,7 @@       LambdaCase       KindSignatures       MultiParamTypeClasses+      MultiWayIf       Rank2Types       ScopedTypeVariables       StandaloneDeriving@@ -82,6 +86,7 @@     , mtl ==2.2.*     , primitive >=0.7 && <0.9     , transformers ==0.5.*+    , vector ==0.12.*   default-language: Haskell2010  test-suite dahdit-test@@ -109,6 +114,7 @@       LambdaCase       KindSignatures       MultiParamTypeClasses+      MultiWayIf       Rank2Types       ScopedTypeVariables       StandaloneDeriving@@ -130,4 +136,5 @@     , tasty     , tasty-hunit     , transformers ==0.5.*+    , vector ==0.12.*   default-language: Haskell2010

@@ -3,22 +3,25 @@   , Int8   , ByteString   , ShortByteString+  , Vector   , Seq (..)   , ByteArray-  , PrimArray   , Generic-  , Prim   , Proxy (..)+  , GetError (..)+  , prettyGetError+  , runCount   , module Dahdit.Binary   , module Dahdit.BinaryRep   , module Dahdit.Fancy   , module Dahdit.Free   , module Dahdit.Funs   , module Dahdit.Generic+  , module Dahdit.Iface   , module Dahdit.LiftedPrim+  , module Dahdit.LiftedPrimArray   , module Dahdit.Nums   , module Dahdit.Proxy-  , module Dahdit.Run   , module Dahdit.Sizes   ) where@@ -29,18 +32,19 @@ import Dahdit.Free (Get, Put, PutM) import Dahdit.Funs hiding (unsafePutStaticArrayN, unsafePutStaticSeqN) import Dahdit.Generic+import Dahdit.Iface import Dahdit.LiftedPrim+import Dahdit.LiftedPrimArray import Dahdit.Nums import Dahdit.Proxy-import Dahdit.Run+import Dahdit.Run (GetError (..), prettyGetError, runCount) import Dahdit.Sizes import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString) import Data.Int (Int8)-import Data.Primitive (Prim) import Data.Primitive.ByteArray (ByteArray)-import Data.Primitive.PrimArray (PrimArray) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq (..))+import Data.Vector.Storable (Vector) import Data.Word (Word8) import GHC.Generics (Generic)

@@ -1,12 +1,13 @@ module Dahdit.Binary   ( Binary (..)-  , byteSizeViaPut   ) where  import Dahdit.Free (Get, Put) import Dahdit.Funs-  ( getFloatBE+  ( getDoubleBE+  , getDoubleLE+  , getFloatBE   , getFloatLE   , getInt16BE   , getInt16LE@@ -14,14 +15,22 @@   , getInt24LE   , getInt32BE   , getInt32LE+  , getInt64BE+  , getInt64LE   , getInt8+  , getList+  , getSeq   , getWord16BE   , getWord16LE   , getWord24BE   , getWord24LE   , getWord32BE   , getWord32LE+  , getWord64BE+  , getWord64LE   , getWord8+  , putDoubleBE+  , putDoubleLE   , putFloatBE   , putFloatLE   , putInt16BE@@ -30,42 +39,65 @@   , putInt24LE   , putInt32BE   , putInt32LE+  , putInt64BE+  , putInt64LE   , putInt8+  , putList+  , putSeq   , putWord16BE   , putWord16LE   , putWord24BE   , putWord24LE   , putWord32BE   , putWord32LE+  , putWord64BE+  , putWord64LE   , putWord8   ) import Dahdit.Nums-  ( FloatBE (..)-  , FloatLE+  ( DoubleBE (..)+  , DoubleLE (..)+  , FloatBE (..)+  , FloatLE (..)   , Int16BE (..)-  , Int16LE+  , Int16LE (..)   , Int24BE (..)-  , Int24LE+  , Int24LE (..)   , Int32BE (..)-  , Int32LE+  , Int32LE (..)+  , Int64BE (..)+  , Int64LE (..)   , Word16BE (..)-  , Word16LE+  , Word16LE (..)   , Word24BE (..)-  , Word24LE+  , Word24LE (..)   , Word32BE (..)-  , Word32LE+  , Word32LE (..)+  , Word64BE (..)+  , Word64LE (..)   )-import Dahdit.Run (runCount)-import Dahdit.Sizes (ByteCount, ByteSized)-import Data.Int (Int8)-import Data.Word (Word8)+import Dahdit.Sizes (ElemCount (..))+import Data.ByteString.Internal (c2w, w2c)+import Data.Coerce (coerce)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.ShortWord (Int24, Word24)+import Data.Word (Word16, Word32, Word64, Word8) -class ByteSized a => Binary a where+class Binary a where   get :: Get a   put :: a -> Put -byteSizeViaPut :: Binary a => a -> ByteCount-byteSizeViaPut = runCount . put+-- Basic types  instance Binary () where   get = pure ()@@ -103,10 +135,22 @@   get = getInt32LE   put = putInt32LE +instance Binary Word64LE where+  get = getWord64LE+  put = putWord64LE++instance Binary Int64LE where+  get = getInt64LE+  put = putInt64LE+ instance Binary FloatLE where   get = getFloatLE   put = putFloatLE +instance Binary DoubleLE where+  get = getDoubleLE+  put = putDoubleLE+ instance Binary Word16BE where   get = getWord16BE   put = putWord16BE@@ -131,6 +175,134 @@   get = getInt32BE   put = putInt32BE +instance Binary Word64BE where+  get = getWord64BE+  put = putWord64BE++instance Binary Int64BE where+  get = getInt64BE+  put = putInt64BE+ instance Binary FloatBE where   get = getFloatBE   put = putFloatBE++instance Binary DoubleBE where+  get = getDoubleBE+  put = putDoubleBE++deriving via Word16LE instance Binary Word16++deriving via Int16LE instance Binary Int16++deriving via Word24LE instance Binary Word24++deriving via Int24LE instance Binary Int24++deriving via Word32LE instance Binary Word32++deriving via Int32LE instance Binary Int32++deriving via Word64LE instance Binary Word64++deriving via Int64LE instance Binary Int64++deriving via FloatLE instance Binary Float++deriving via DoubleLE instance Binary Double++instance Binary Bool where+  get = fmap (/= 0) getWord8+  put b = putWord8 (if b then 1 else 0)++instance Binary Char where+  get = fmap w2c getWord8+  put = putWord8 . c2w++instance Binary Int where+  get = fmap fromIntegral getInt64LE+  put = putInt64LE . fromIntegral++instance Binary a => Binary [a] where+  get = do+    ec <- get @Int+    getList (coerce ec) get+  put s = put @Int (length s) *> putList put s++instance Binary a => Binary (Seq a) where+  get = do+    ec <- get @Int+    getSeq (coerce ec) get+  put s = put @Int (Seq.length s) *> putSeq put s++instance Binary a => Binary (Set a) where+  get = fmap Set.fromDistinctAscList get+  put = put . Set.toAscList++instance (Binary k, Binary v) => Binary (Map k v) where+  get = fmap Map.fromDistinctAscList get+  put = put . Map.toAscList++instance Binary IntSet where+  get = fmap IntSet.fromDistinctAscList get+  put = put . IntSet.toAscList++instance Binary v => Binary (IntMap v) where+  get = fmap IntMap.fromDistinctAscList get+  put = put . IntMap.toAscList++instance Binary a => Binary (Maybe a) where+  get = do+    tag <- get @Int+    case tag of+      0 -> pure Nothing+      1 -> fmap Just get+      _ -> fail "Unknown encoding for constructor"+  put = \case+    Nothing -> put @Int 0+    Just a -> put @Int 1 *> put a++instance (Binary b, Binary a) => Binary (Either b a) where+  get = do+    tag <- get @Int+    case tag of+      0 -> fmap Left get+      1 -> fmap Right get+      _ -> fail "Unknown encoding for constructor"+  put = \case+    Left b -> put @Int 0 *> put b+    Right a -> put @Int 1 *> put a++instance (Binary a, Binary b) => Binary (a, b) where+  get = do+    a <- get+    b <- get+    pure (a, b)+  put (a, b) = put a *> put b++instance (Binary a, Binary b, Binary c) => Binary (a, b, c) where+  get = do+    a <- get+    b <- get+    c <- get+    pure (a, b, c)+  put (a, b, c) = put a *> put b *> put c++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) where+  get = do+    a <- get+    b <- get+    c <- get+    d <- get+    pure (a, b, c, d)+  put (a, b, c, d) = put a *> put b *> put c *> put d++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a, b, c, d, e) where+  get = do+    a <- get+    b <- get+    c <- get+    d <- get+    e <- get+    pure (a, b, c, d, e)+  put (a, b, c, d, e) = put a *> put b *> put c *> put d *> put e

@@ -3,6 +3,7 @@ module Dahdit.BinaryRep   ( BinaryRep (..)   , ViaBoundedEnum (..)+  , ViaIntegral (..)   , ViaBinaryRep (..)   ) where@@ -25,9 +26,15 @@           else Right (ViaBoundedEnum (toEnum i))   toBinaryRep = fromIntegral . fromEnum . unViaBoundedEnum +newtype ViaIntegral x a = ViaIntegral {unViaIntegral :: a}++instance (Binary x, Integral x, Integral a) => BinaryRep x (ViaIntegral x a) where+  fromBinaryRep = Right . ViaIntegral . fromIntegral+  toBinaryRep = fromIntegral . unViaIntegral+ newtype ViaBinaryRep a = ViaBinaryRep {unViaBinaryRep :: a} -instance BinaryRep x a => ByteSized (ViaBinaryRep a) where+instance (ByteSized x, BinaryRep x a) => ByteSized (ViaBinaryRep a) where   byteSize = byteSize . toBinaryRep . unViaBinaryRep  instance (StaticByteSized x, BinaryRep x a) => StaticByteSized (ViaBinaryRep a) where

@@ -18,12 +18,12 @@ import Dahdit.Binary (Binary (..)) import Dahdit.Fancy (BoolByte, ExactBytes, StaticArray, StaticSeq, TermBytes) import Dahdit.Free (Get, Put)+import Dahdit.LiftedPrim (LiftedPrim) import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE, Int24BE, Int24LE, Int32BE, Int32LE, Word16BE, Word16LE, Word24BE, Word24LE, Word32BE, Word32LE) import Dahdit.Sizes (ByteSized (..), StaticByteSized) import Data.Coerce (coerce) import Data.Default (Default) import Data.Int (Int8)-import Data.Primitive (Prim) import Data.Word (Word8) import GHC.TypeLits (KnownNat, KnownSymbol) @@ -114,7 +114,7 @@  deriving via (ViaBinary (StaticSeq n a)) instance (KnownNat n, Binary a, StaticByteSized a, Default a) => HasCodec (StaticSeq n a) -deriving via (ViaBinary (StaticArray n a)) instance (KnownNat n, Prim a, StaticByteSized a, Default a) => HasCodec (StaticArray n a)+deriving via (ViaBinary (StaticArray n a)) instance (KnownNat n, LiftedPrim a, Default a) => HasCodec (StaticArray n a)  deriving via (ViaBinary BoolByte) instance HasCodec BoolByte @@ -125,6 +125,6 @@ instance ByteSized a => ByteSized (ViaCodec a) where   byteSize = byteSize . unViaCodec -instance (ByteSized a, HasCodec a) => Binary (ViaCodec a) where+instance HasCodec a => Binary (ViaCodec a) where   get = coerce (parse (codec @a))   put = coerce (produce (codec @a))

@@ -25,15 +25,16 @@   , unsafePutStaticArrayN   , unsafePutStaticSeqN   )+import Dahdit.LiftedPrim (LiftedPrim)+import Dahdit.LiftedPrimArray (LiftedPrimArray, replicateLiftedPrimArray) import Dahdit.Proxy (proxyForNatF)-import Dahdit.Sizes (ByteSized (..), StaticByteSized (..), ViaStaticByteSized (..))+import Dahdit.Sizes (ByteCount (..), ByteSized (..), StaticByteSized (..), ViaStaticByteSized (..)) import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Short as BSS import Data.ByteString.Short.Internal (ShortByteString (..))+import Data.Coerce (coerce) import Data.Default (Default (..))-import Data.Primitive (Prim) import Data.Primitive.ByteArray (ByteArray (..), byteArrayFromListN)-import Data.Primitive.PrimArray (PrimArray, replicatePrimArray) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq) import qualified Data.Sequence as Seq@@ -41,19 +42,17 @@ import Data.Word (Word8) import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) -getUntilNull :: Get (Int, [Word8])+getUntilNull :: Get (ByteCount, [Word8]) getUntilNull = go 0 []  where   go !i !racc = do     w <- getWord8     if w == 0-      then-        let !acc = reverse racc-        in  pure (i, acc)+      then pure (i, reverse racc)       else go (i + 1) (w : racc) -mkSBS :: Int -> [Word8] -> ShortByteString-mkSBS n bs = let !(ByteArray ba) = byteArrayFromListN n bs in SBS ba+mkSBS :: ByteCount -> [Word8] -> ShortByteString+mkSBS n bs = let !(ByteArray ba) = byteArrayFromListN (coerce n) bs in SBS ba  -- | Bytes terminated with null byte. -- NOTE: Terminated with TWO null bytes if the string is even length@@ -67,17 +66,17 @@  instance ByteSized TermBytes where   byteSize (TermBytes sbs) =-    let !bc = byteSize sbs + 1+    let bc = byteSize sbs + 1     in  if even bc then bc else bc + 1  instance Binary TermBytes where   get = do-    (!i, acc) <- getUntilNull+    (i, acc) <- getUntilNull     unless (odd i) $ do       w <- getWord8       unless (w == 0) (fail "TermBytes missing word pad")-    let !sbs = mkSBS i acc-    pure $! TermBytes sbs+    let sbs = mkSBS i acc+    pure (TermBytes sbs)    put (TermBytes sbs) = do     putByteString sbs@@ -88,8 +87,9 @@ newtype StaticBytes (n :: Nat) = StaticBytes {unStaticBytes :: ShortByteString}   deriving stock (Show)   deriving newtype (IsString)-  deriving (ByteSized) via (ViaStaticByteSized (StaticBytes n)) +deriving via (ViaStaticByteSized (StaticBytes n)) instance KnownNat n => ByteSized (StaticBytes n)+ mkStaticBytes :: KnownNat n => Proxy n -> ShortByteString -> StaticBytes n mkStaticBytes prox sbs =   let n = fromInteger (natVal prox)@@ -134,29 +134,30 @@   deriving (ByteSized) via (ViaStaticByteSized (StaticSeq n a))  instance (KnownNat n, Default a) => Default (StaticSeq n a) where-  def = StaticSeq (Seq.replicate (fromIntegral (natVal (Proxy :: Proxy n))) def)+  def = StaticSeq (Seq.replicate (fromInteger (natVal (Proxy :: Proxy n))) def)  instance (KnownNat n, StaticByteSized a) => StaticByteSized (StaticSeq n a) where-  staticByteSize _ = fromIntegral (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a)+  staticByteSize _ = fromInteger (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a)  instance (KnownNat n, Binary a, StaticByteSized a, Default a) => Binary (StaticSeq n a) where-  get = fmap StaticSeq (getStaticSeq (fromIntegral (natVal (Proxy :: Proxy n))) get)-  put = unsafePutStaticSeqN (fromIntegral (natVal (Proxy :: Proxy n))) (Just def) put . unStaticSeq+  get = fmap StaticSeq (getStaticSeq (fromInteger (natVal (Proxy :: Proxy n))) get)+  put = unsafePutStaticSeqN (fromInteger (natVal (Proxy :: Proxy n))) (Just def) put . unStaticSeq -newtype StaticArray (n :: Nat) a = StaticArray {unStaticArray :: PrimArray a}+newtype StaticArray (n :: Nat) a = StaticArray {unStaticArray :: LiftedPrimArray a}   deriving stock (Show)   deriving newtype (Eq)-  deriving (ByteSized) via (ViaStaticByteSized (StaticArray n a)) -instance (KnownNat n, Prim a, Default a) => Default (StaticArray n a) where-  def = StaticArray (replicatePrimArray (fromIntegral (natVal (Proxy :: Proxy n))) def)+deriving via (ViaStaticByteSized (StaticArray n a)) instance (KnownNat n, StaticByteSized a) => ByteSized (StaticArray n a) +instance (KnownNat n, LiftedPrim a, Default a) => Default (StaticArray n a) where+  def = StaticArray (replicateLiftedPrimArray (fromInteger (natVal (Proxy :: Proxy n))) def)+ instance (KnownNat n, StaticByteSized a) => StaticByteSized (StaticArray n a) where-  staticByteSize _ = fromIntegral (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a)+  staticByteSize _ = fromInteger (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a) -instance (KnownNat n, Prim a, StaticByteSized a, Default a) => Binary (StaticArray n a) where-  get = fmap StaticArray (getStaticArray (fromIntegral (natVal (Proxy :: Proxy n))))-  put = unsafePutStaticArrayN (fromIntegral (natVal (Proxy :: Proxy n))) (Just def) . unStaticArray+instance (KnownNat n, LiftedPrim a, Default a) => Binary (StaticArray n a) where+  get = fmap StaticArray (getStaticArray (fromInteger (natVal (Proxy :: Proxy n))))+  put = unsafePutStaticArrayN (fromInteger (natVal (Proxy :: Proxy n))) (Just def) . unStaticArray  newtype BoolByte = BoolByte {unBoolByte :: Bool}   deriving stock (Show)@@ -182,15 +183,15 @@   def = ExactBytes ()  instance KnownSymbol s => StaticByteSized (ExactBytes s) where-  staticByteSize _ = fromIntegral (length (symbolVal (Proxy :: Proxy s)))+  staticByteSize _ = coerce (length (symbolVal (Proxy :: Proxy s)))  instance KnownSymbol s => Binary (ExactBytes s) where   get = do-    let !s = symbolVal (Proxy :: Proxy s)-        !bc = fromIntegral (length s)-        !bs = BSS.pack (fmap c2w s)+    let s = symbolVal (Proxy :: Proxy s)+        bc = coerce (length s)+        bs = BSS.pack (fmap c2w s)     getExpect s (getByteString bc) bs-    pure $! ExactBytes ()+    pure (ExactBytes ())   put _ = do-    let !s = symbolVal (Proxy :: Proxy s)+    let s = symbolVal (Proxy :: Proxy s)     putByteString (BSS.pack (fmap c2w s))

@@ -16,8 +16,12 @@ where  import Control.Monad.Free.Church (F (..))+import Dahdit.LiftedPrim (LiftedPrim)+import Dahdit.LiftedPrimArray (LiftedPrimArray) import Dahdit.Nums-  ( FloatBE+  ( DoubleBE+  , DoubleLE+  , FloatBE   , FloatLE   , Int16BE   , Int16LE@@ -25,30 +29,33 @@   , Int24LE   , Int32BE   , Int32LE+  , Int64BE+  , Int64LE   , Word16BE   , Word16LE   , Word24BE   , Word24LE   , Word32BE   , Word32LE+  , Word64BE+  , Word64LE   )-import Dahdit.Sizes (ByteCount, ElementCount, StaticByteSized (..))+import Dahdit.Sizes (ByteCount, ElemCount, StaticByteSized (..)) import Data.ByteString.Short (ShortByteString) import Data.Int (Int8)-import Data.Primitive (ByteArray, Prim)-import Data.Primitive.PrimArray (PrimArray)+import Data.Primitive (ByteArray) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq) import Data.Word (Word8)  data GetStaticSeqF a where-  GetStaticSeqF :: (StaticByteSized z) => !ElementCount -> Get z -> (Seq z -> a) -> GetStaticSeqF a+  GetStaticSeqF :: StaticByteSized z => !ElemCount -> Get z -> (Seq z -> a) -> GetStaticSeqF a  instance Functor GetStaticSeqF where   fmap f (GetStaticSeqF n g k) = GetStaticSeqF n g (f . k)  data GetStaticArrayF a where-  GetStaticArrayF :: (StaticByteSized z, Prim z) => !ElementCount -> Proxy z -> (PrimArray z -> a) -> GetStaticArrayF a+  GetStaticArrayF :: LiftedPrim z => !ElemCount -> Proxy z -> (LiftedPrimArray z -> a) -> GetStaticArrayF a  instance Functor GetStaticArrayF where   fmap f (GetStaticArrayF n p k) = GetStaticArrayF n p (f . k)@@ -79,14 +86,20 @@   | GetFInt24LE (Int24LE -> a)   | GetFWord32LE (Word32LE -> a)   | GetFInt32LE (Int32LE -> a)+  | GetFWord64LE (Word64LE -> a)+  | GetFInt64LE (Int64LE -> a)   | GetFFloatLE (FloatLE -> a)+  | GetFDoubleLE (DoubleLE -> a)   | GetFWord16BE (Word16BE -> a)   | GetFInt16BE (Int16BE -> a)   | GetFWord24BE (Word24BE -> a)   | GetFInt24BE (Int24BE -> a)   | GetFWord32BE (Word32BE -> a)   | GetFInt32BE (Int32BE -> a)+  | GetFWord64BE (Word64BE -> a)+  | GetFInt64BE (Int64BE -> a)   | GetFFloatBE (FloatBE -> a)+  | GetFDoubleBE (DoubleBE -> a)   | GetFShortByteString !ByteCount (ShortByteString -> a)   | GetFStaticSeq !(GetStaticSeqF a)   | GetFStaticArray !(GetStaticArrayF a)@@ -105,13 +118,13 @@   fail msg = Get (F (\_ y -> y (GetFFail msg)))  data PutStaticSeqF a where-  PutStaticSeqF :: StaticByteSized z => !ElementCount -> !(Maybe z) -> (z -> Put) -> !(Seq z) -> a -> PutStaticSeqF a+  PutStaticSeqF :: StaticByteSized z => !ElemCount -> !(Maybe z) -> (z -> Put) -> !(Seq z) -> a -> PutStaticSeqF a  instance Functor PutStaticSeqF where   fmap f (PutStaticSeqF n z p s k) = PutStaticSeqF n z p s (f k)  data PutStaticArrayF a where-  PutStaticArrayF :: (StaticByteSized z, Prim z) => !ElementCount -> !(Maybe z) -> !(PrimArray z) -> a -> PutStaticArrayF a+  PutStaticArrayF :: LiftedPrim z => !ElemCount -> !(Maybe z) -> !(LiftedPrimArray z) -> a -> PutStaticArrayF a  instance Functor PutStaticArrayF where   fmap f (PutStaticArrayF n z a k) = PutStaticArrayF n z a (f k)@@ -131,14 +144,20 @@   | PutFInt24LE !Int24LE a   | PutFWord32LE !Word32LE a   | PutFInt32LE !Int32LE a+  | PutFWord64LE !Word64LE a+  | PutFInt64LE !Int64LE a   | PutFFloatLE !FloatLE a+  | PutFDoubleLE !DoubleLE a   | PutFWord16BE !Word16BE a   | PutFInt16BE !Int16BE a   | PutFWord24BE !Word24BE a   | PutFInt24BE !Int24BE a   | PutFWord32BE !Word32BE a+  | PutFWord64BE !Word64BE a+  | PutFInt64BE !Int64BE a   | PutFInt32BE !Int32BE a   | PutFFloatBE !FloatBE a+  | PutFDoubleBE !DoubleBE a   | PutFShortByteString !ByteCount !ShortByteString a   | PutFStaticSeq !(PutStaticSeqF a)   | PutFStaticArray !(PutStaticArrayF a)

@@ -7,18 +7,25 @@   , getInt24LE   , getWord32LE   , getInt32LE+  , getWord64LE+  , getInt64LE   , getFloatLE+  , getDoubleLE   , getWord16BE   , getInt16BE   , getWord24BE   , getInt24BE   , getWord32BE   , getInt32BE+  , getWord64BE+  , getInt64BE   , getFloatBE+  , getDoubleBE   , getByteString   , getSkip   , getExact   , getWithin+  , getList   , getSeq   , getStaticSeq   , getStaticArray@@ -42,16 +49,23 @@   , putInt24LE   , putWord32LE   , putInt32LE+  , putWord64LE+  , putInt64LE   , putFloatLE+  , putDoubleLE   , putWord16BE   , putInt16BE   , putWord24BE   , putInt24BE   , putWord32BE   , putInt32BE+  , putWord64BE+  , putInt64BE   , putFloatBE+  , putDoubleBE   , putByteString   , putFixedString+  , putList   , putSeq   , putStaticSeq   , unsafePutStaticSeqN@@ -80,9 +94,12 @@   , PutStaticSeqF (..)   , ScopeMode (..)   )-import Dahdit.LiftedPrim (LiftedPrim (..), LiftedPrimArray (..))+import Dahdit.LiftedPrim (LiftedPrim (..))+import Dahdit.LiftedPrimArray (LiftedPrimArray (..), lengthLiftedPrimArray) import Dahdit.Nums-  ( FloatBE+  ( DoubleBE+  , DoubleLE+  , FloatBE   , FloatLE   , Int16BE   , Int16LE@@ -90,22 +107,26 @@   , Int24LE   , Int32BE   , Int32LE+  , Int64BE+  , Int64LE   , Word16BE   , Word16LE   , Word24BE   , Word24LE   , Word32BE   , Word32LE+  , Word64BE+  , Word64LE   ) import Dahdit.Proxy (proxyForF, proxyForFun)-import Dahdit.Sizes (ByteCount (..), ElementCount (..), StaticByteSized (..))+import Dahdit.Sizes (ByteCount (..), ElemCount (..), StaticByteSized (..)) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS+import Data.Coerce (coerce) import Data.Foldable (traverse_) import Data.Int (Int8)-import Data.Primitive (Prim, sizeofByteArray, sizeofPrimArray)+import Data.Primitive (sizeofByteArray) import Data.Primitive.ByteArray (ByteArray)-import Data.Primitive.PrimArray (PrimArray) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq@@ -135,9 +156,18 @@ getInt32LE :: Get Int32LE getInt32LE = Get (F (\x y -> y (GetFInt32LE x))) +getWord64LE :: Get Word64LE+getWord64LE = Get (F (\x y -> y (GetFWord64LE x)))++getInt64LE :: Get Int64LE+getInt64LE = Get (F (\x y -> y (GetFInt64LE x)))+ getFloatLE :: Get FloatLE getFloatLE = Get (F (\x y -> y (GetFFloatLE x))) +getDoubleLE :: Get DoubleLE+getDoubleLE = Get (F (\x y -> y (GetFDoubleLE x)))+ getWord16BE :: Get Word16BE getWord16BE = Get (F (\x y -> y (GetFWord16BE x))) @@ -156,9 +186,18 @@ getInt32BE :: Get Int32BE getInt32BE = Get (F (\x y -> y (GetFInt32BE x))) +getWord64BE :: Get Word64BE+getWord64BE = Get (F (\x y -> y (GetFWord64BE x)))++getInt64BE :: Get Int64BE+getInt64BE = Get (F (\x y -> y (GetFInt64BE x)))+ getFloatBE :: Get FloatBE getFloatBE = Get (F (\x y -> y (GetFFloatBE x))) +getDoubleBE :: Get DoubleBE+getDoubleBE = Get (F (\x y -> y (GetFDoubleBE x)))+ getByteString :: ByteCount -> Get ShortByteString getByteString bc = Get (F (\x y -> y (GetFShortByteString bc x))) @@ -171,31 +210,42 @@ getWithin :: ByteCount -> Get a -> Get a getWithin bc g = Get (F (\x y -> y (GetFScope (GetScopeF ScopeModeWithin bc g x)))) +-- | Get List of dynamically-sized elements+getList :: ElemCount -> Get a -> Get [a]+getList ec g = go [] 0+ where+  go !acc !i =+    if i == ec+      then pure (reverse acc)+      else do+        x <- g+        go (x : acc) (i + 1)+ -- | Get Seq of dynamically-sized elements-getSeq :: ElementCount -> Get a -> Get (Seq a)+getSeq :: ElemCount -> Get a -> Get (Seq a) getSeq ec g = go Empty 0  where-  go !acc i =+  go !acc !i =     if i == ec       then pure acc       else do         x <- g-        x `seq` go (acc :|> x) (i + 1)+        go (acc :|> x) (i + 1)  -- | Get Seq of statically-sized elements-getStaticSeq :: (StaticByteSized a) => ElementCount -> Get a -> Get (Seq a)+getStaticSeq :: StaticByteSized a => ElemCount -> Get a -> Get (Seq a) getStaticSeq n g = Get (F (\x y -> y (GetFStaticSeq (GetStaticSeqF n g x))))  -- | Get PrimArray of statically-sized elements-getStaticArray :: (StaticByteSized a, Prim a) => ElementCount -> Get (PrimArray a)+getStaticArray :: LiftedPrim a => ElemCount -> Get (LiftedPrimArray a) getStaticArray n = Get (F (\x y -> y (GetFStaticArray (GetStaticArrayF n (Proxy :: Proxy a) x))))  getByteArray :: ByteCount -> Get ByteArray getByteArray bc = Get (F (\x y -> y (GetFByteArray bc x))) -getLiftedPrimArray :: LiftedPrim a => Proxy a -> ElementCount -> Get (LiftedPrimArray a)+getLiftedPrimArray :: LiftedPrim a => Proxy a -> ElemCount -> Get (LiftedPrimArray a) getLiftedPrimArray prox ec =-  let !bc = fromIntegral (elemSizeLifted prox * fromIntegral ec)+  let bc = staticByteSize prox * coerce ec   in  fmap LiftedPrimArray (getByteArray bc)  getLookAhead :: Get a -> Get a@@ -216,41 +266,37 @@       then pure acc       else do         x <- g-        x `seq` go (acc :|> x)+        go (acc :|> x) -getRemainingStaticSeq :: (StaticByteSized a) => Get a -> Get (Seq a)+getRemainingStaticSeq :: StaticByteSized a => Get a -> Get (Seq a) getRemainingStaticSeq g = do-  let !ebc = staticByteSize (proxyForF g)+  let ebc = staticByteSize (proxyForF g)   bc <- getRemainingSize-  let !left = rem bc ebc+  let left = rem bc ebc   if left == 0-    then do-      let !ec = fromIntegral (div bc ebc)-      getStaticSeq ec g+    then getStaticSeq (coerce (div bc ebc)) g     else fail ("Leftover bytes for remaining static seq (have " ++ show (unByteCount left) ++ ", need " ++ show (unByteCount ebc) ++ ")") -getRemainingStaticArray :: (StaticByteSized a, Prim a) => Proxy a -> Get (PrimArray a)+getRemainingStaticArray :: LiftedPrim a => Proxy a -> Get (LiftedPrimArray a) getRemainingStaticArray prox = do-  let !ebc = staticByteSize prox+  let ebc = staticByteSize prox   bc <- getRemainingSize-  let !left = rem bc ebc+  let left = rem bc ebc   if left == 0-    then do-      let !ec = fromIntegral (div bc ebc)-      getStaticArray ec+    then getStaticArray (coerce (div bc ebc))     else fail ("Leftover bytes for remaining static array (have " ++ show (unByteCount left) ++ ", need " ++ show (unByteCount ebc) ++ ")")  getRemainingByteArray :: Get ByteArray getRemainingByteArray = getRemainingSize >>= getByteArray -getRemainingLiftedPrimArray :: (LiftedPrim a) => Proxy a -> Get (LiftedPrimArray a)+getRemainingLiftedPrimArray :: LiftedPrim a => Proxy a -> Get (LiftedPrimArray a) getRemainingLiftedPrimArray prox = do-  let !ebc = fromIntegral (elemSizeLifted prox)+  let ebc = staticByteSize prox   bc <- getRemainingSize-  let !left = rem bc ebc+  let left = rem bc ebc   if left == 0     then do-      let !ec = fromIntegral (div bc ebc)+      let ec = coerce (div bc ebc)       getLiftedPrimArray prox ec     else fail ("Leftover bytes for remaining lifted prim array (have " ++ show (unByteCount left) ++ ", need " ++ show (unByteCount ebc) ++ ")") @@ -292,9 +338,18 @@ putInt32LE :: Int32LE -> Put putInt32LE d = PutM (F (\x y -> y (PutFInt32LE d (x ())))) +putWord64LE :: Word64LE -> Put+putWord64LE d = PutM (F (\x y -> y (PutFWord64LE d (x ()))))++putInt64LE :: Int64LE -> Put+putInt64LE d = PutM (F (\x y -> y (PutFInt64LE d (x ()))))+ putFloatLE :: FloatLE -> Put putFloatLE d = PutM (F (\x y -> y (PutFFloatLE d (x ())))) +putDoubleLE :: DoubleLE -> Put+putDoubleLE d = PutM (F (\x y -> y (PutFDoubleLE d (x ()))))+ putWord16BE :: Word16BE -> Put putWord16BE d = PutM (F (\x y -> y (PutFWord16BE d (x ())))) @@ -313,25 +368,38 @@ putInt32BE :: Int32BE -> Put putInt32BE d = PutM (F (\x y -> y (PutFInt32BE d (x ())))) +putWord64BE :: Word64BE -> Put+putWord64BE d = PutM (F (\x y -> y (PutFWord64BE d (x ()))))++putInt64BE :: Int64BE -> Put+putInt64BE d = PutM (F (\x y -> y (PutFInt64BE d (x ()))))+ putFloatBE :: FloatBE -> Put putFloatBE d = PutM (F (\x y -> y (PutFFloatBE d (x ())))) +putDoubleBE :: DoubleBE -> Put+putDoubleBE d = PutM (F (\x y -> y (PutFDoubleBE d (x ()))))+ putByteString :: ShortByteString -> Put putByteString sbs =-  let !bc = fromIntegral (BSS.length sbs)+  let bc = coerce (BSS.length sbs)   in  PutM (F (\x y -> y (PutFShortByteString bc sbs (x ()))))  putFixedString :: Word8 -> ByteCount -> ShortByteString -> Put putFixedString pad bc sbs = do   unless (bc == 0) $ do-    let !len = fromIntegral bc-        !lenSbs = BSS.length sbs-        !mostLen = min len lenSbs-        !mostBc = fromIntegral mostLen+    let len = coerce bc+        lenSbs = BSS.length sbs+        mostLen = min len lenSbs+        mostBc = coerce mostLen     PutM (F (\x y -> y (PutFShortByteString mostBc sbs (x ()))))-    let !diff = len - lenSbs+    let diff = len - lenSbs     unless (diff <= 0) (replicateM_ diff (putWord8 pad)) +-- | Put List of dynamically-sized elements+putList :: (a -> Put) -> [a] -> Put+putList = traverse_+ -- | Put Seq of dynamically-sized elements putSeq :: (a -> Put) -> Seq a -> Put putSeq = traverse_@@ -339,30 +407,30 @@ -- | Put Seq of statically-sized elements putStaticSeq :: StaticByteSized a => (a -> Put) -> Seq a -> Put putStaticSeq p s =-  let !n = fromIntegral (Seq.length s)+  let n = coerce (Seq.length s)   in  unsafePutStaticSeqN n Nothing p s -unsafePutStaticSeqN :: StaticByteSized a => ElementCount -> Maybe a -> (a -> Put) -> Seq a -> Put+unsafePutStaticSeqN :: StaticByteSized a => ElemCount -> Maybe a -> (a -> Put) -> Seq a -> Put unsafePutStaticSeqN n mz p s = PutM (F (\x y -> y (PutFStaticSeq (PutStaticSeqF n mz p s (x ())))))  -- | Put Array of statically-sized elements-putStaticArray :: (StaticByteSized a, Prim a) => PrimArray a -> Put+putStaticArray :: LiftedPrim a => LiftedPrimArray a -> Put putStaticArray a =-  let !n = fromIntegral (sizeofPrimArray a)-  in  unsafePutStaticArrayN n Nothing a+  let ec = lengthLiftedPrimArray a+  in  unsafePutStaticArrayN ec Nothing a -unsafePutStaticArrayN :: (StaticByteSized a, Prim a) => ElementCount -> Maybe a -> PrimArray a -> Put+unsafePutStaticArrayN :: LiftedPrim a => ElemCount -> Maybe a -> LiftedPrimArray a -> Put unsafePutStaticArrayN n mz a = PutM (F (\x y -> y (PutFStaticArray (PutStaticArrayF n mz a (x ())))))  putByteArray :: ByteArray -> Put putByteArray arr =-  let !bc = fromIntegral (sizeofByteArray arr)+  let bc = coerce (sizeofByteArray arr)   in  PutM (F (\x y -> y (PutFByteArray bc arr (x ()))))  putLiftedPrimArray :: LiftedPrimArray a -> Put putLiftedPrimArray = putByteArray . unLiftedPrimArray  putStaticHint :: StaticByteSized a => (a -> Put) -> a -> Put-putStaticHint p =-  let !bc = staticByteSize (proxyForFun p)-  in  \a -> PutM (F (\x y -> y (PutFStaticHint (PutStaticHintF bc (p a) (x ())))))+putStaticHint p a =+  let bc = staticByteSize (proxyForFun p)+  in  PutM (F (\x y -> y (PutFStaticHint (PutStaticHintF bc (p a) (x ())))))

@@ -10,10 +10,13 @@ import Dahdit.Binary (Binary (..)) import Dahdit.Free (Get, Put) import Dahdit.Funs (putStaticHint)+import Dahdit.Nums (Word16LE, Word32LE) import Dahdit.Sizes (ByteCount, ByteSized (..), StaticByteSized (..))+import Data.Bits (Bits (..)) import Data.Kind (Type) import Data.Proxy (Proxy (..))-import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..))+import Data.Word (Word8)+import GHC.Generics (C1, Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..), (:+:) (..))  -- | Use: deriving (ByteSized, Binary) via (ViaGeneric Foo) newtype ViaGeneric a = ViaGeneric {unViaGeneric :: a}@@ -38,6 +41,13 @@ instance GByteSized a => GByteSized (M1 i c a) where   gbyteSize = gbyteSize . unM1 +-- Sum+instance (GByteSized a, GByteSized b, SumSize a, SumSize b) => GByteSized (a :+: b) where+  gbyteSize s =+    sumSizeBytes s + case s of+      L1 a -> gbyteSize a+      R1 b -> gbyteSize b+ -- Field instance ByteSized a => GByteSized (K1 i a) where   gbyteSize = byteSize . unK1@@ -70,7 +80,7 @@  -- Binary: -class GByteSized f => GBinary (f :: Type -> Type) where+class GBinary (f :: Type -> Type) where   gget :: Get (f a)   gput :: f a -> Put @@ -97,3 +107,95 @@ instance (Generic t, GStaticByteSized (Rep t), GBinary (Rep t)) => Binary (ViaStaticGeneric t) where   get = fmap (ViaStaticGeneric . to) gget   put = putStaticHint (gput . from . unViaStaticGeneric)++-- Everything that follows is borrowed from the binary package, which+-- borrows from the cereal package!++-- The following GBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++instance+  ( GSumBinary a+  , GSumBinary b+  , SumSize a+  , SumSize b+  )+  => GBinary (a :+: b)+  where+  gget+    | size - 1 <= fromIntegral (maxBound :: Word8) = (get :: Get Word8) >>= checkGetSum (fromIntegral size)+    | size - 1 <= fromIntegral (maxBound :: Word16LE) = (get :: Get Word16LE) >>= checkGetSum (fromIntegral size)+    | size - 1 <= (maxBound :: Word32LE) = (get :: Get Word32LE) >>= checkGetSum size+    | otherwise = sizeError "decode" size+   where+    size = unTagged (sumSize :: Tagged (a :+: b))+  gput+    | size - 1 <= fromIntegral (maxBound :: Word8) = putSum (0 :: Word8) (fromIntegral size)+    | size - 1 <= fromIntegral (maxBound :: Word16LE) = putSum (0 :: Word16LE) (fromIntegral size)+    | size - 1 <= (maxBound :: Word32LE) = putSum (0 :: Word32LE) size+    | otherwise = sizeError "encode" size+   where+    size = unTagged (sumSize :: Tagged (a :+: b))++sizeError :: Show size => String -> size -> error+sizeError s size = error ("Can't " ++ s ++ " a type with " ++ show size ++ " constructors")++checkGetSum+  :: (Ord word, Num word, Bits word, GSumBinary f)+  => word+  -> word+  -> Get (f a)+checkGetSum size code+  | code < size = getSum code size+  | otherwise = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSumBinary f where+  getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+  putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSumBinary a, GSumBinary b) => GSumBinary (a :+: b) where+  getSum !code !size+    | code < sizeL = L1 <$> getSum code sizeL+    | otherwise = R1 <$> getSum (code - sizeL) sizeR+   where+    sizeL = size `shiftR` 1+    sizeR = size - sizeL+  putSum !code !size s = case s of+    L1 x -> putSum code sizeL x+    R1 x -> putSum (code + sizeL) sizeR x+   where+    sizeL = size `shiftR` 1+    sizeR = size - sizeL++instance GBinary a => GSumBinary (C1 c a) where+  getSum _ _ = gget+  putSum !code _ x = put code <> gput x++class SumSize (f :: Type -> Type) where+  sumSize :: Tagged f++newtype Tagged (s :: Type -> Type) = Tagged {unTagged :: Word32LE}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+  sumSize = Tagged (unTagged (sumSize :: Tagged a) + unTagged (sumSize :: Tagged b))++instance SumSize (C1 c a) where+  sumSize = Tagged 1++sumSizeFor :: SumSize f => f a -> Tagged f+sumSizeFor = const sumSize++taggedBytes :: Tagged f -> ByteCount+taggedBytes (Tagged size)+  | size - 1 <= fromIntegral (maxBound :: Word8) = 1+  | size - 1 <= fromIntegral (maxBound :: Word16LE) = 2+  | size - 1 <= (maxBound :: Word32LE) = 4+  | otherwise = sizeError "size" size++sumSizeBytes :: SumSize f => f a -> ByteCount+sumSizeBytes = taggedBytes . sumSizeFor

@@ -0,0 +1,98 @@+module Dahdit.Iface+  ( BinaryTarget (..)+  , getTarget+  , putTarget+  , decode+  , decodeFile+  , encode+  , encodeFile+  )+where++import Dahdit.Binary (Binary (..))+import Dahdit.Free (Get, Put)+import Dahdit.Mem (allocArrayMem, allocPtrMem, freezeBSMem, freezeSBSMem, freezeVecMem, viewBSMem, viewSBSMem, viewVecMem)+import Dahdit.Run (GetError, runCount, runGetInternal, runPutInternal)+import Dahdit.Sizes (ByteCount (..), ByteSized (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as BSS+import Data.Coerce (coerce)+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as VS+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.+  -- Prefer 'putTarget' to safely count capacity, or use 'encode' to use byte size.+  putTargetUnsafe :: Put -> ByteCount -> z++  -- | Get a value from the source given a starting offset, returning a result and final offset.+  -- On error, the offset will indicate where in the source the error occurred.+  getTargetOffset :: ByteCount -> Get a -> z -> (Either GetError a, ByteCount)++-- | Get a value from the source, returning a result and final offset.+getTarget :: BinaryTarget z => Get a -> z -> (Either GetError a, ByteCount)+getTarget = getTargetOffset 0++-- | Put an action to the sink with calculated capacity.+putTarget :: BinaryTarget z => Put -> z+putTarget p = putTargetUnsafe p (runCount p)++instance BinaryTarget ShortByteString where+  getTargetOffset = runGetSBS+  putTargetUnsafe = runPutSBS++instance BinaryTarget ByteString where+  getTargetOffset = runGetBS+  putTargetUnsafe = runPutBS++instance BinaryTarget (Vector Word8) where+  getTargetOffset = runGetVec+  putTargetUnsafe = runPutVec++-- | 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++-- | Decode a value from a file.+decodeFile :: Binary a => FilePath -> IO (Either GetError a, ByteCount)+decodeFile = runGetFile get++-- | Encode a value to a sink.+encode :: (Binary a, ByteSized a, BinaryTarget z) => a -> z+encode a = putTargetUnsafe (put a) (byteSize a)++-- | Encode a value to a file.+encodeFile :: (Binary a, ByteSized a) => a -> FilePath -> IO ()+encodeFile a = runPutFile (put a) (byteSize a)++runGetSBS :: ByteCount -> Get a -> ShortByteString -> (Either GetError a, ByteCount)+runGetSBS off act sbs = runGetInternal off act (coerce (BSS.length sbs)) (viewSBSMem sbs)++runGetBS :: ByteCount -> Get a -> ByteString -> (Either GetError a, ByteCount)+runGetBS off act bs = runGetInternal off act (coerce (BS.length bs)) (viewBSMem bs)++runGetVec :: ByteCount -> Get a -> Vector Word8 -> (Either GetError a, ByteCount)+runGetVec off act vec = runGetInternal off act (coerce (VS.length vec)) (viewVecMem vec)++runGetFile :: Get a -> FilePath -> IO (Either GetError a, ByteCount)+runGetFile act fp = do+  bs <- BS.readFile fp+  pure (runGetBS 0 act bs)++runPutSBS :: Put -> ByteCount -> ShortByteString+runPutSBS act cap = runPutInternal act cap allocArrayMem freezeSBSMem++runPutBS :: Put -> ByteCount -> ByteString+runPutBS act cap = runPutInternal act cap allocPtrMem freezeBSMem++runPutVec :: Put -> ByteCount -> Vector Word8+runPutVec act cap = runPutInternal act cap allocPtrMem freezeVecMem++runPutFile :: Put -> ByteCount -> FilePath -> IO ()+runPutFile act cap fp =+  let bs = runPutBS act cap+  in  BS.writeFile fp bs

@@ -1,10 +1,10 @@ module Dahdit.Internal where  import Data.Bits (Bits (..))-import Data.Int (Int16, Int32, Int8)+import Data.Int (Int16, Int32, Int64, Int8) import Data.ShortWord (Int24, Word24)-import Data.Word (Word16, Word32, Word8)-import GHC.Float (castFloatToWord32, castWord32ToFloat)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Float (castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble)  newtype ViaFromIntegral x y = ViaFromIntegral {unViaFromIntegral :: y}   deriving newtype (Num)@@ -24,37 +24,49 @@  instance SwapEndian Word16 where   swapEndian w =-    let (b0, b1) = unMkWord16LE w+    let (!b0, !b1) = unMkWord16LE w     in  mkWord16LE b1 b0  deriving via (ViaFromIntegral Word16 Int16) instance SwapEndian Int16  instance SwapEndian Word24 where   swapEndian w =-    let (b0, b1, b2) = unMkWord24LE w+    let (!b0, !b1, !b2) = unMkWord24LE w     in  mkWord24LE b2 b1 b0  deriving via (ViaFromIntegral Word24 Int24) instance SwapEndian Int24  instance SwapEndian Word32 where   swapEndian w =-    let (b0, b1, b2, b3) = unMkWord32LE w+    let (!b0, !b1, !b2, !b3) = unMkWord32LE w     in  mkWord32LE b3 b2 b1 b0  deriving via (ViaFromIntegral Word32 Int32) instance SwapEndian Int32 +instance SwapEndian Word64 where+  swapEndian w =+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkWord64LE w+    in  mkWord64LE b7 b6 b5 b4 b3 b2 b1 b0++deriving via (ViaFromIntegral Word64 Int64) instance SwapEndian Int64+ instance SwapEndian Float where   swapEndian w =-    let (b0, b1, b2, b3) = unMkFloatLE w+    let (!b0, !b1, !b2, !b3) = unMkFloatLE w     in  mkFloatLE b3 b2 b1 b0 +instance SwapEndian Double where+  swapEndian w =+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkDoubleLE w+    in  mkDoubleLE b7 b6 b5 b4 b3 b2 b1 b0+ mkWord16LE :: Word8 -> Word8 -> Word16 mkWord16LE b0 b1 = (fromIntegral b1 `unsafeShiftL` 8) .|. fromIntegral b0  unMkWord16LE :: Word16 -> (Word8, Word8) unMkWord16LE w =-  let !b0 = fromIntegral w-      !b1 = fromIntegral (w `shiftR` 8)+  let b0 = fromIntegral w+      b1 = fromIntegral (w `shiftR` 8)   in  (b0, b1)  mkWord24LE :: Word8 -> Word8 -> Word8 -> Word24@@ -62,8 +74,8 @@  unMkWord24LE :: Word24 -> (Word8, Word8, Word8) unMkWord24LE w =-  let !v = fromIntegral w-      (b0, b1, b2, _) = unMkWord32LE v+  let v = fromIntegral w+      (!b0, !b1, !b2, _) = unMkWord32LE v   in  (b0, b1, b2)  mkWord32LE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32@@ -75,14 +87,57 @@  unMkWord32LE :: Word32 -> (Word8, Word8, Word8, Word8) unMkWord32LE w =-  let !b0 = fromIntegral w-      !b1 = fromIntegral (w `shiftR` 8)-      !b2 = fromIntegral (w `shiftR` 16)-      !b3 = fromIntegral (w `shiftR` 24)+  let b0 = fromIntegral w+      b1 = fromIntegral (w `shiftR` 8)+      b2 = fromIntegral (w `shiftR` 16)+      b3 = fromIntegral (w `shiftR` 24)   in  (b0, b1, b2, b3) +mkWord64LE :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word64+mkWord64LE b0 b1 b2 b3 b4 b5 b6 b7 =+  (fromIntegral b7 `unsafeShiftL` 56)+    .|. (fromIntegral b6 `unsafeShiftL` 48)+    .|. (fromIntegral b5 `unsafeShiftL` 40)+    .|. (fromIntegral b4 `unsafeShiftL` 32)+    .|. (fromIntegral b3 `unsafeShiftL` 24)+    .|. (fromIntegral b2 `unsafeShiftL` 16)+    .|. (fromIntegral b1 `unsafeShiftL` 8)+    .|. fromIntegral b0++unMkWord64LE :: Word64 -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)+unMkWord64LE w =+  let b0 = fromIntegral w+      b1 = fromIntegral (w `shiftR` 8)+      b2 = fromIntegral (w `shiftR` 16)+      b3 = fromIntegral (w `shiftR` 24)+      b4 = fromIntegral (w `shiftR` 32)+      b5 = fromIntegral (w `shiftR` 40)+      b6 = fromIntegral (w `shiftR` 48)+      b7 = fromIntegral (w `shiftR` 56)+  in  (b0, b1, b2, b3, b4, b5, b6, b7)+ mkFloatLE :: Word8 -> Word8 -> Word8 -> Word8 -> Float mkFloatLE b0 b1 b2 b3 = castWord32ToFloat (mkWord32LE b0 b1 b2 b3)  unMkFloatLE :: Float -> (Word8, Word8, Word8, Word8) unMkFloatLE f = unMkWord32LE (castFloatToWord32 f)++mkDoubleLE :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Double+mkDoubleLE b0 b1 b2 b3 b4 b5 b6 b7 = castWord64ToDouble (mkWord64LE b0 b1 b2 b3 b4 b5 b6 b7)++unMkDoubleLE :: Double -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)+unMkDoubleLE f = unMkWord64LE (castDoubleToWord64 f)++class (Num le, Num be) => EndianPair le be | le -> be, be -> le where+  toLittleEndian :: be -> le+  toBigEndian :: le -> be++newtype ViaEndianPair le be = ViaEndianPair {unViaEndianPair :: be}++instance EndianPair Word8 Word8 where+  toLittleEndian = id+  toBigEndian = id++instance EndianPair Int8 Int8 where+  toLittleEndian = id+  toBigEndian = id

@@ -1,139 +1,330 @@+{-# LANGUAGE UndecidableInstances #-}+ module Dahdit.LiftedPrim   ( LiftedPrim (..)-  , LiftedPrimArray (..)-  , MutableLiftedPrimArray (..)-  , emptyLiftedPrimArray-  , indexLiftedPrimArray-  , writeLiftedPrimArray-  , freezeLiftedPrimArray-  , thawLiftedPrimArray-  , unsafeFreezeLiftedPrimArray-  , unsafeThawLiftedPrimArray-  , liftedPrimArrayFromListN-  , liftedPrimArrayFromList-  , generateLiftedPrimArray-  , sizeofLiftedPrimArray-  , cloneLiftedPrimArray+  , indexArrayLiftedInElems+  , writeArrayLiftedInElems+  , indexPtrLiftedInElems+  , writePtrLiftedInElems+  , setByteArrayLifted   ) where  import Control.Monad.Primitive (PrimMonad (..))-import Dahdit.Internal (ViaFromIntegral (..))-import Dahdit.Proxy (proxyForF)-import Data.Default (Default (..))+import Dahdit.Internal (EndianPair (..), ViaEndianPair (..), ViaFromIntegral (..), mkDoubleLE, mkFloatLE, mkWord16LE, mkWord24LE, mkWord32LE, mkWord64LE, unMkDoubleLE, unMkFloatLE, unMkWord16LE, unMkWord24LE, unMkWord32LE, unMkWord64LE)+import Dahdit.Nums+  ( DoubleBE+  , DoubleLE (..)+  , FloatBE+  , FloatLE (..)+  , Int16BE+  , Int16LE (..)+  , Int24BE+  , Int24LE (..)+  , Int32BE+  , Int32LE (..)+  , Int64BE+  , Int64LE (..)+  , Word16BE+  , Word16LE (..)+  , Word24BE+  , Word24LE (..)+  , Word32BE+  , Word32LE (..)+  , Word64BE+  , Word64LE (..)+  )+import Dahdit.Proxy (proxyFor)+import Dahdit.Sizes (ByteCount (..), ElemCount (..), StaticByteSized (..))+import Data.Coerce (coerce) import Data.Foldable (for_) import Data.Int (Int8) import Data.Primitive.ByteArray   ( ByteArray   , MutableByteArray-  , cloneByteArray-  , emptyByteArray-  , freezeByteArray   , indexByteArray-  , newByteArray-  , runByteArray-  , sizeofByteArray-  , thawByteArray-  , unsafeFreezeByteArray-  , unsafeThawByteArray   , writeByteArray   )+import Data.Primitive.Ptr (indexOffPtr, writeOffPtr) import Data.Proxy (Proxy (..))-import Data.STRef (modifySTRef', newSTRef, readSTRef) import Data.Word (Word8)+import Foreign.Ptr (Ptr)  -- | This is a stripped-down version of 'Prim' that is possible for a human to implement.--- It's all about reading and writing structures from byte arrays.-class LiftedPrim a where-  elemSizeLifted :: Proxy a -> Int-  indexByteArrayLiftedInBytes :: ByteArray -> Int -> a-  indexByteArrayLiftedInElems :: ByteArray -> Int -> a-  indexByteArrayLiftedInElems arr pos =-    let !sz = elemSizeLifted (Proxy :: Proxy a)-    in  indexByteArrayLiftedInBytes arr (pos * sz)-  writeByteArrayLiftedInBytes :: PrimMonad m => a -> MutableByteArray (PrimState m) -> Int -> m ()-  writeByteArrayLiftedInElems :: PrimMonad m => a -> MutableByteArray (PrimState m) -> Int -> m ()-  writeByteArrayLiftedInElems val arr pos =-    let !sz = elemSizeLifted (Proxy :: Proxy a)-    in  writeByteArrayLiftedInBytes val arr (pos * sz)+-- It's all about reading and writing structures from lifted byte arrays and pointers.+class StaticByteSized a => LiftedPrim a where+  indexArrayLiftedInBytes :: ByteArray -> ByteCount -> a+  writeArrayLiftedInBytes :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> a -> m ()+  indexPtrLiftedInBytes :: Ptr Word8 -> ByteCount -> a+  writePtrLiftedInBytes :: PrimMonad m => Ptr Word8 -> ByteCount -> a -> m () +indexArrayLiftedInElems :: LiftedPrim a => Proxy a -> ByteArray -> ElemCount -> a+indexArrayLiftedInElems prox arr pos =+  indexArrayLiftedInBytes arr (coerce pos * staticByteSize prox)++writeArrayLiftedInElems :: (PrimMonad m, LiftedPrim a) => MutableByteArray (PrimState m) -> ElemCount -> a -> m ()+writeArrayLiftedInElems arr pos val =+  writeArrayLiftedInBytes arr (coerce pos * staticByteSize (proxyFor val)) val++indexPtrLiftedInElems :: LiftedPrim a => Proxy a -> Ptr Word8 -> ElemCount -> a+indexPtrLiftedInElems prox ptr pos =+  indexPtrLiftedInBytes ptr (coerce pos * staticByteSize prox)++writePtrLiftedInElems :: (PrimMonad m, LiftedPrim a) => Ptr Word8 -> ElemCount -> a -> m ()+writePtrLiftedInElems ptr pos val =+  writePtrLiftedInBytes ptr (coerce pos * staticByteSize (proxyFor val)) val+ instance LiftedPrim Word8 where-  elemSizeLifted _ = 1-  indexByteArrayLiftedInBytes = indexByteArray-  writeByteArrayLiftedInBytes val arr pos = writeByteArray arr pos val+  indexArrayLiftedInBytes arr = indexByteArray arr . coerce+  writeArrayLiftedInBytes marr = writeByteArray marr . coerce+  indexPtrLiftedInBytes ptr = indexOffPtr ptr . coerce+  writePtrLiftedInBytes ptr = writeOffPtr ptr . coerce  instance LiftedPrim Int8 where-  elemSizeLifted _ = 1-  indexByteArrayLiftedInBytes = indexByteArray-  indexByteArrayLiftedInElems = indexByteArray-  writeByteArrayLiftedInBytes val arr pos = writeByteArray arr pos val-  writeByteArrayLiftedInElems val arr pos = writeByteArray arr pos val+  indexArrayLiftedInBytes arr = indexByteArray arr . coerce+  writeArrayLiftedInBytes marr = writeByteArray marr . coerce+  indexPtrLiftedInBytes ptr = indexOffPtr (coerce ptr) . coerce+  writePtrLiftedInBytes ptr = writeOffPtr (coerce ptr) . coerce  -- | NOTE: Relies on same byte width of both types! instance (Integral x, LiftedPrim x, Integral y) => LiftedPrim (ViaFromIntegral x y) where-  elemSizeLifted _ = elemSizeLifted (Proxy :: Proxy x)-  indexByteArrayLiftedInBytes arr pos = ViaFromIntegral (fromIntegral (indexByteArrayLiftedInBytes arr pos :: x))-  writeByteArrayLiftedInBytes val arr pos = let !x = fromIntegral (unViaFromIntegral val) :: x in writeByteArrayLiftedInBytes x arr pos+  indexArrayLiftedInBytes arr off = ViaFromIntegral (fromIntegral (indexArrayLiftedInBytes arr off :: x))+  writeArrayLiftedInBytes arr off val = let x = fromIntegral (unViaFromIntegral val) :: x in writeArrayLiftedInBytes arr off x+  indexPtrLiftedInBytes ptr = ViaFromIntegral . fromIntegral @x @y . indexPtrLiftedInBytes ptr+  writePtrLiftedInBytes ptr off (ViaFromIntegral y) = writePtrLiftedInBytes ptr off (fromIntegral y :: x) -newtype LiftedPrimArray a = LiftedPrimArray {unLiftedPrimArray :: ByteArray}-  deriving stock (Show)-  deriving newtype (Eq, Semigroup, Monoid)+instance LiftedPrim Word16LE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexByteArray arr (coerce off)+        !b1 = indexByteArray arr (coerce off + 1)+    in  Word16LE (mkWord16LE b0 b1) -instance Default (LiftedPrimArray a) where-  def = emptyLiftedPrimArray+  writeArrayLiftedInBytes arr off w =+    let (!b0, !b1) = unMkWord16LE (unWord16LE w)+    in  writeByteArray arr (coerce off) b0+          *> writeByteArray arr (coerce off + 1) b1 -newtype MutableLiftedPrimArray m a = MutableLiftedPrimArray {unMutableLiftedPrimArray :: MutableByteArray m}-  deriving newtype (Eq)+  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+    in  Word16LE (mkWord16LE b0 b1) -emptyLiftedPrimArray :: LiftedPrimArray a-emptyLiftedPrimArray = LiftedPrimArray emptyByteArray+  writePtrLiftedInBytes ptr off w =+    let (!b0, !b1) = unMkWord16LE (unWord16LE w)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1 -indexLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> Int -> a-indexLiftedPrimArray (LiftedPrimArray arr) = indexByteArrayLiftedInElems arr+instance LiftedPrim Word24LE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexByteArray arr (coerce off)+        !b1 = indexByteArray arr (coerce off + 1)+        !b2 = indexByteArray arr (coerce off + 2)+    in  Word24LE (mkWord24LE b0 b1 b2) -writeLiftedPrimArray :: (LiftedPrim a, PrimMonad m) => a -> MutableLiftedPrimArray (PrimState m) a -> Int -> m ()-writeLiftedPrimArray val (MutableLiftedPrimArray arr) = writeByteArrayLiftedInElems val arr+  writeArrayLiftedInBytes arr off w = do+    let (!b0, !b1, !b2) = unMkWord24LE (unWord24LE w)+    writeByteArray arr (coerce off) b0+    writeByteArray arr (coerce off + 1) b1+    writeByteArray arr (coerce off + 2) b2 -freezeLiftedPrimArray :: PrimMonad m => MutableLiftedPrimArray (PrimState m) a -> Int -> Int -> m (LiftedPrimArray a)-freezeLiftedPrimArray (MutableLiftedPrimArray arr) off len = fmap LiftedPrimArray (freezeByteArray arr off len)+  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+        !b2 = indexOffPtr ptr (coerce off + 2)+    in  Word24LE (mkWord24LE b0 b1 b2) -unsafeFreezeLiftedPrimArray :: PrimMonad m => MutableLiftedPrimArray (PrimState m) a -> m (LiftedPrimArray a)-unsafeFreezeLiftedPrimArray (MutableLiftedPrimArray arr) = fmap LiftedPrimArray (unsafeFreezeByteArray arr)+  writePtrLiftedInBytes ptr off w =+    let (!b0, !b1, !b2) = unMkWord24LE (unWord24LE w)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1+          *> writeOffPtr ptr (coerce off + 2) b2 -thawLiftedPrimArray :: PrimMonad m => LiftedPrimArray a -> Int -> Int -> m (MutableLiftedPrimArray (PrimState m) a)-thawLiftedPrimArray (LiftedPrimArray arr) off len = fmap MutableLiftedPrimArray (thawByteArray arr off len)+instance LiftedPrim Word32LE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexByteArray arr (coerce off)+        !b1 = indexByteArray arr (coerce off + 1)+        !b2 = indexByteArray arr (coerce off + 2)+        !b3 = indexByteArray arr (coerce off + 3)+    in  Word32LE (mkWord32LE b0 b1 b2 b3) -unsafeThawLiftedPrimArray :: PrimMonad m => LiftedPrimArray a -> m (MutableLiftedPrimArray (PrimState m) a)-unsafeThawLiftedPrimArray (LiftedPrimArray arr) = fmap MutableLiftedPrimArray (unsafeThawByteArray arr)+  writeArrayLiftedInBytes arr off w = do+    let (!b0, !b1, !b2, !b3) = unMkWord32LE (unWord32LE w)+    writeByteArray arr (coerce off) b0+    writeByteArray arr (coerce off + 1) b1+    writeByteArray arr (coerce off + 2) b2+    writeByteArray arr (coerce off + 3) b3 -liftedPrimArrayFromListN :: LiftedPrim a => Int -> [a] -> LiftedPrimArray a-liftedPrimArrayFromListN n xs = LiftedPrimArray $ runByteArray $ do-  let !elemSize = elemSizeLifted (proxyForF xs)-      !len = n * elemSize-  arr <- newByteArray len-  offRef <- newSTRef 0-  for_ xs $ \x -> do-    off <- readSTRef offRef-    writeByteArrayLiftedInBytes x arr off-    modifySTRef' offRef (elemSize +)-  pure arr+  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+        !b2 = indexOffPtr ptr (coerce off + 2)+        !b3 = indexOffPtr ptr (coerce off + 3)+    in  Word32LE (mkWord32LE b0 b1 b2 b3) -liftedPrimArrayFromList :: LiftedPrim a => [a] -> LiftedPrimArray a-liftedPrimArrayFromList xs = liftedPrimArrayFromListN (length xs) xs+  writePtrLiftedInBytes ptr off w =+    let (!b0, !b1, !b2, !b3) = unMkWord32LE (unWord32LE w)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1+          *> writeOffPtr ptr (coerce off + 2) b2+          *> writeOffPtr ptr (coerce off + 3) b3 -generateLiftedPrimArray :: LiftedPrim a => Int -> (Int -> a) -> LiftedPrimArray a-generateLiftedPrimArray n f = liftedPrimArrayFromListN n (fmap f [0 .. n - 1])+instance LiftedPrim Word64LE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexArrayLiftedInBytes arr (coerce off)+        !b1 = indexArrayLiftedInBytes arr (coerce off + 1)+        !b2 = indexArrayLiftedInBytes arr (coerce off + 2)+        !b3 = indexArrayLiftedInBytes arr (coerce off + 3)+        !b4 = indexArrayLiftedInBytes arr (coerce off + 4)+        !b5 = indexArrayLiftedInBytes arr (coerce off + 5)+        !b6 = indexArrayLiftedInBytes arr (coerce off + 6)+        !b7 = indexArrayLiftedInBytes arr (coerce off + 7)+    in  Word64LE (mkWord64LE b0 b1 b2 b3 b4 b5 b6 b7) -sizeofLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> Int-sizeofLiftedPrimArray pa@(LiftedPrimArray arr) =-  let !elemSize = elemSizeLifted (proxyForF pa)-      !arrSize = sizeofByteArray arr-  in  div arrSize elemSize+  writeArrayLiftedInBytes arr off w = do+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkWord64LE (unWord64LE w)+    writeByteArray arr (coerce off) b0+    writeByteArray arr (coerce off + 1) b1+    writeByteArray arr (coerce off + 2) b2+    writeByteArray arr (coerce off + 3) b3+    writeByteArray arr (coerce off + 4) b4+    writeByteArray arr (coerce off + 5) b5+    writeByteArray arr (coerce off + 6) b6+    writeByteArray arr (coerce off + 7) b7 -cloneLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> Int -> Int -> LiftedPrimArray a-cloneLiftedPrimArray pa@(LiftedPrimArray arr) off len =-  let !elemSize = elemSizeLifted (proxyForF pa)-      !byteOff = off * elemSize-      !byteLen = len * elemSize-      !arr' = cloneByteArray arr byteOff byteLen-  in  LiftedPrimArray arr'+  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+        !b2 = indexOffPtr ptr (coerce off + 2)+        !b3 = indexOffPtr ptr (coerce off + 3)+        !b4 = indexOffPtr ptr (coerce off + 4)+        !b5 = indexOffPtr ptr (coerce off + 5)+        !b6 = indexOffPtr ptr (coerce off + 6)+        !b7 = indexOffPtr ptr (coerce off + 7)+    in  Word64LE (mkWord64LE b0 b1 b2 b3 b4 b5 b6 b7)++  writePtrLiftedInBytes ptr off w =+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkWord64LE (unWord64LE w)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1+          *> writeOffPtr ptr (coerce off + 2) b2+          *> writeOffPtr ptr (coerce off + 3) b3+          *> writeOffPtr ptr (coerce off + 4) b4+          *> writeOffPtr ptr (coerce off + 5) b5+          *> writeOffPtr ptr (coerce off + 6) b6+          *> writeOffPtr ptr (coerce off + 7) b7++instance LiftedPrim FloatLE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexByteArray arr (coerce off)+        !b1 = indexByteArray arr (coerce off + 1)+        !b2 = indexByteArray arr (coerce off + 2)+        !b3 = indexByteArray arr (coerce off + 3)+    in  FloatLE (mkFloatLE b0 b1 b2 b3)++  writeArrayLiftedInBytes arr off f = do+    let (!b0, !b1, !b2, !b3) = unMkFloatLE (unFloatLE f)+    writeByteArray arr (coerce off) b0+    writeByteArray arr (coerce off + 1) b1+    writeByteArray arr (coerce off + 2) b2+    writeByteArray arr (coerce off + 3) b3++  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+        !b2 = indexOffPtr ptr (coerce off + 2)+        !b3 = indexOffPtr ptr (coerce off + 3)+    in  FloatLE (mkFloatLE b0 b1 b2 b3)++  writePtrLiftedInBytes ptr off f =+    let (!b0, !b1, !b2, !b3) = unMkFloatLE (unFloatLE f)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1+          *> writeOffPtr ptr (coerce off + 2) b2+          *> writeOffPtr ptr (coerce off + 3) b3++instance LiftedPrim DoubleLE where+  indexArrayLiftedInBytes arr off =+    let !b0 = indexArrayLiftedInBytes arr (coerce off)+        !b1 = indexArrayLiftedInBytes arr (coerce off + 1)+        !b2 = indexArrayLiftedInBytes arr (coerce off + 2)+        !b3 = indexArrayLiftedInBytes arr (coerce off + 3)+        !b4 = indexArrayLiftedInBytes arr (coerce off + 4)+        !b5 = indexArrayLiftedInBytes arr (coerce off + 5)+        !b6 = indexArrayLiftedInBytes arr (coerce off + 6)+        !b7 = indexArrayLiftedInBytes arr (coerce off + 7)+    in  DoubleLE (mkDoubleLE b0 b1 b2 b3 b4 b5 b6 b7)++  writeArrayLiftedInBytes arr off f = do+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkDoubleLE (unDoubleLE f)+    writeByteArray arr (coerce off) b0+    writeByteArray arr (coerce off + 1) b1+    writeByteArray arr (coerce off + 2) b2+    writeByteArray arr (coerce off + 3) b3+    writeByteArray arr (coerce off + 4) b4+    writeByteArray arr (coerce off + 5) b5+    writeByteArray arr (coerce off + 6) b6+    writeByteArray arr (coerce off + 7) b7++  indexPtrLiftedInBytes ptr off =+    let !b0 = indexOffPtr ptr (coerce off)+        !b1 = indexOffPtr ptr (coerce off + 1)+        !b2 = indexOffPtr ptr (coerce off + 2)+        !b3 = indexOffPtr ptr (coerce off + 3)+        !b4 = indexOffPtr ptr (coerce off + 4)+        !b5 = indexOffPtr ptr (coerce off + 5)+        !b6 = indexOffPtr ptr (coerce off + 6)+        !b7 = indexOffPtr ptr (coerce off + 7)+    in  DoubleLE (mkDoubleLE b0 b1 b2 b3 b4 b5 b6 b7)++  writePtrLiftedInBytes ptr off f =+    let (!b0, !b1, !b2, !b3, !b4, !b5, !b6, !b7) = unMkDoubleLE (unDoubleLE f)+    in  writeOffPtr ptr (coerce off) b0+          *> writeOffPtr ptr (coerce off + 1) b1+          *> writeOffPtr ptr (coerce off + 2) b2+          *> writeOffPtr ptr (coerce off + 3) b3+          *> writeOffPtr ptr (coerce off + 4) b4+          *> writeOffPtr ptr (coerce off + 5) b5+          *> writeOffPtr ptr (coerce off + 6) b6+          *> writeOffPtr ptr (coerce off + 7) b7++instance (LiftedPrim le, EndianPair le be) => LiftedPrim (ViaEndianPair le be) where+  indexArrayLiftedInBytes arr off = ViaEndianPair (toBigEndian (indexArrayLiftedInBytes arr off))+  writeArrayLiftedInBytes arr off = writeArrayLiftedInBytes arr off . toLittleEndian . unViaEndianPair+  indexPtrLiftedInBytes ptr off = ViaEndianPair (toBigEndian (indexPtrLiftedInBytes ptr off))+  writePtrLiftedInBytes ptr off = writePtrLiftedInBytes ptr off . toLittleEndian . unViaEndianPair++deriving via (ViaFromIntegral Word16LE Int16LE) instance LiftedPrim Int16LE++deriving via (ViaFromIntegral Word24LE Int24LE) instance LiftedPrim Int24LE++deriving via (ViaFromIntegral Word32LE Int32LE) instance LiftedPrim Int32LE++deriving via (ViaFromIntegral Word64LE Int64LE) instance LiftedPrim Int64LE++deriving via (ViaEndianPair Word16LE Word16BE) instance LiftedPrim Word16BE++deriving via (ViaEndianPair Int16LE Int16BE) instance LiftedPrim Int16BE++deriving via (ViaEndianPair Word24LE Word24BE) instance LiftedPrim Word24BE++deriving via (ViaEndianPair Int24LE Int24BE) instance LiftedPrim Int24BE++deriving via (ViaEndianPair Word32LE Word32BE) instance LiftedPrim Word32BE++deriving via (ViaEndianPair Int32LE Int32BE) instance LiftedPrim Int32BE++deriving via (ViaEndianPair Word64LE Word64BE) instance LiftedPrim Word64BE++deriving via (ViaEndianPair Int64LE Int64BE) instance LiftedPrim Int64BE++deriving via (ViaEndianPair FloatLE FloatBE) instance LiftedPrim FloatBE++deriving via (ViaEndianPair DoubleLE DoubleBE) instance LiftedPrim DoubleBE++-- | Fill a byte array with the given value+setByteArrayLifted :: (PrimMonad m, LiftedPrim a) => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> a -> m ()+setByteArrayLifted arr off len val = do+  let elemSize = staticByteSize (proxyFor val)+      elemLen = div (coerce len) elemSize+  for_ [0 .. elemLen - 1] $ \pos ->+    writeArrayLiftedInBytes arr (off + pos * elemSize) val

@@ -0,0 +1,124 @@+module Dahdit.LiftedPrimArray+  ( LiftedPrimArray (..)+  , MutableLiftedPrimArray (..)+  , emptyLiftedPrimArray+  , indexLiftedPrimArray+  , writeLiftedPrimArray+  , freezeLiftedPrimArray+  , thawLiftedPrimArray+  , unsafeFreezeLiftedPrimArray+  , unsafeThawLiftedPrimArray+  , liftedPrimArrayFromListN+  , liftedPrimArrayFromList+  , generateLiftedPrimArray+  , sizeofLiftedPrimArray+  , lengthLiftedPrimArray+  , cloneLiftedPrimArray+  , replicateLiftedPrimArray+  )+where++import Control.Monad.Primitive (PrimMonad (..))+import Dahdit.LiftedPrim+  ( LiftedPrim (..)+  , indexArrayLiftedInElems+  , writeArrayLiftedInElems+  )+import Dahdit.Proxy (proxyFor, proxyForF)+import Dahdit.Sizes (ByteCount (..), ByteSized (..), ElemCount (..), StaticByteSized (..))+import Data.Coerce (coerce)+import Data.Default (Default (..))+import Data.Foldable (for_)+import Data.Primitive.ByteArray+  ( ByteArray+  , MutableByteArray+  , cloneByteArray+  , emptyByteArray+  , freezeByteArray+  , newByteArray+  , runByteArray+  , sizeofByteArray+  , thawByteArray+  , unsafeFreezeByteArray+  , unsafeThawByteArray+  )+import Data.Proxy (Proxy (..))+import Data.STRef (modifySTRef', newSTRef, readSTRef)++newtype LiftedPrimArray a = LiftedPrimArray {unLiftedPrimArray :: ByteArray}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Semigroup, Monoid)++instance Default (LiftedPrimArray a) where+  def = emptyLiftedPrimArray++instance ByteSized (LiftedPrimArray a) where+  byteSize = sizeofLiftedPrimArray++newtype MutableLiftedPrimArray m a = MutableLiftedPrimArray {unMutableLiftedPrimArray :: MutableByteArray m}+  deriving newtype (Eq)++emptyLiftedPrimArray :: LiftedPrimArray a+emptyLiftedPrimArray = LiftedPrimArray emptyByteArray++indexLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> ElemCount -> a+indexLiftedPrimArray (LiftedPrimArray arr) = indexArrayLiftedInElems Proxy arr++writeLiftedPrimArray :: (LiftedPrim a, PrimMonad m) => MutableLiftedPrimArray (PrimState m) a -> ElemCount -> a -> m ()+writeLiftedPrimArray (MutableLiftedPrimArray arr) = writeArrayLiftedInElems arr++freezeLiftedPrimArray :: PrimMonad m => MutableLiftedPrimArray (PrimState m) a -> ElemCount -> ElemCount -> m (LiftedPrimArray a)+freezeLiftedPrimArray (MutableLiftedPrimArray arr) off len = fmap LiftedPrimArray (freezeByteArray arr (coerce off) (coerce len))++unsafeFreezeLiftedPrimArray :: PrimMonad m => MutableLiftedPrimArray (PrimState m) a -> m (LiftedPrimArray a)+unsafeFreezeLiftedPrimArray (MutableLiftedPrimArray arr) = fmap LiftedPrimArray (unsafeFreezeByteArray arr)++thawLiftedPrimArray :: PrimMonad m => LiftedPrimArray a -> ElemCount -> ElemCount -> m (MutableLiftedPrimArray (PrimState m) a)+thawLiftedPrimArray (LiftedPrimArray arr) off len = fmap MutableLiftedPrimArray (thawByteArray arr (coerce off) (coerce len))++unsafeThawLiftedPrimArray :: PrimMonad m => LiftedPrimArray a -> m (MutableLiftedPrimArray (PrimState m) a)+unsafeThawLiftedPrimArray (LiftedPrimArray arr) = fmap MutableLiftedPrimArray (unsafeThawByteArray arr)++liftedPrimArrayFromListN :: LiftedPrim a => ElemCount -> [a] -> LiftedPrimArray a+liftedPrimArrayFromListN n xs = LiftedPrimArray $ runByteArray $ do+  let elemSize = staticByteSize (proxyForF xs)+      len = coerce n * coerce elemSize+  arr <- newByteArray len+  offRef <- newSTRef 0+  for_ xs $ \x -> do+    off <- readSTRef offRef+    writeArrayLiftedInBytes arr off x+    modifySTRef' offRef (elemSize +)+  pure arr++liftedPrimArrayFromList :: LiftedPrim a => [a] -> LiftedPrimArray a+liftedPrimArrayFromList xs = liftedPrimArrayFromListN (coerce (length xs)) xs++generateLiftedPrimArray :: LiftedPrim a => ElemCount -> (ElemCount -> a) -> LiftedPrimArray a+generateLiftedPrimArray n f = liftedPrimArrayFromListN n (fmap f [0 .. n - 1])++sizeofLiftedPrimArray :: LiftedPrimArray a -> ByteCount+sizeofLiftedPrimArray (LiftedPrimArray arr) = coerce (sizeofByteArray arr)++lengthLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> ElemCount+lengthLiftedPrimArray pa@(LiftedPrimArray arr) =+  let elemSize = coerce (staticByteSize (proxyForF pa))+      arrSize = sizeofByteArray arr+  in  coerce (div arrSize elemSize)++cloneLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> ElemCount -> ElemCount -> LiftedPrimArray a+cloneLiftedPrimArray pa@(LiftedPrimArray arr) off len =+  let elemSize = staticByteSize (proxyForF pa)+      byteOff = coerce off * elemSize+      byteLen = coerce len * elemSize+      arr' = cloneByteArray arr (coerce byteOff) (coerce byteLen)+  in  LiftedPrimArray arr'++replicateLiftedPrimArray :: LiftedPrim a => ElemCount -> a -> LiftedPrimArray a+replicateLiftedPrimArray len val = LiftedPrimArray $ runByteArray $ do+  let elemSize = staticByteSize (proxyFor val)+      byteLen = coerce len * elemSize+  arr <- newByteArray (coerce byteLen)+  for_ [0 .. len - 1] $ \pos ->+    writeArrayLiftedInBytes arr (coerce pos * elemSize) val+  pure arr

@@ -0,0 +1,133 @@+module Dahdit.Mem+  ( IxPtr (..)+  , ReadMem (..)+  , readSBSMem+  , viewSBSMem+  , viewBSMem+  , viewVecMem+  , WriteMem (..)+  , writeSBSMem+  , allocArrayMem+  , allocPtrMem+  , freezeSBSMem+  , freezeBSMem+  , freezeVecMem+  )+where++import Control.Monad.ST (ST, runST)+import Control.Monad.ST.Unsafe (unsafeIOToST)+import Dahdit.LiftedPrim (LiftedPrim (..), setByteArrayLifted)+import Dahdit.Proxy (proxyFor)+import Dahdit.Sizes (ByteCount (..), staticByteSize)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BSI+import Data.ByteString.Short.Internal (ShortByteString (..))+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.Ptr (copyPtrToMutableByteArray)+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as VS+import Data.Word (Word8)+import Foreign.ForeignPtr (newForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Marshal.Alloc (callocBytes, finalizerFree, free)+import Foreign.Ptr (Ptr, plusPtr)++-- | A wrapper over 'Ptr' with an additional phantom type index to align with 'ST' state.+newtype IxPtr s = IxPtr {unIxPtr :: Ptr Word8}+  deriving stock (Show)+  deriving newtype (Eq, Ord)++class ReadMem r where+  indexMemInBytes :: LiftedPrim a => r -> ByteCount -> a+  cloneArrayMemInBytes :: r -> ByteCount -> ByteCount -> ByteArray++instance ReadMem ByteArray where+  indexMemInBytes = indexArrayLiftedInBytes+  cloneArrayMemInBytes arr off len = cloneByteArray arr (coerce off) (coerce len)++clonePtr :: Ptr Word8 -> ByteCount -> ByteCount -> ByteArray+clonePtr ptr off len = runST $ do+  let wptr = coerce (plusPtr ptr (coerce off)) :: Ptr Word8+  marr <- newByteArray (coerce len)+  copyPtrToMutableByteArray marr 0 wptr (coerce len)+  unsafeFreezeByteArray marr++instance ReadMem (Ptr Word8) where+  indexMemInBytes = indexPtrLiftedInBytes+  cloneArrayMemInBytes = clonePtr++readSBSMem :: ReadMem r => r -> ByteCount -> ByteCount -> ShortByteString+readSBSMem mem off len = let !(ByteArray frozArr) = cloneArrayMemInBytes mem off len in SBS frozArr++viewSBSMem :: ShortByteString -> ByteArray+viewSBSMem (SBS harr) = ByteArray harr++viewBSMem :: ByteString -> Ptr Word8+viewBSMem bs =+  let (fp, _) = BSI.toForeignPtr0 bs+  in  unsafeForeignPtrToPtr fp++viewVecMem :: Vector Word8 -> Ptr Word8+viewVecMem vec =+  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 ())++instance WriteMem MutableByteArray 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 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 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+  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 (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++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))++freezeBSMem :: IxPtr s -> ByteCount -> ByteCount -> ST s ByteString+freezeBSMem (IxPtr ptr) _ len =+  unsafeIOToST (BSU.unsafePackCStringFinalizer ptr (coerce len) (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))++allocPtrMem :: ByteCount -> ST s (IxPtr s)+allocPtrMem = fmap IxPtr . unsafeIOToST . callocBytes . coerce++allocArrayMem :: ByteCount -> ST s (MutableByteArray s)+allocArrayMem = newByteArray . coerce

@@ -4,197 +4,128 @@ -- | Derived instances rely on the host system being little-endian. -- If it's not, well... some CPP is in order. module Dahdit.Nums-  ( EndianPair (..)-  , Word16LE (..)+  ( Word16LE (..)   , Int16LE (..)   , Word24LE (..)   , Int24LE (..)   , Word32LE (..)   , Int32LE (..)+  , Word64LE (..)+  , Int64LE (..)   , FloatLE (..)+  , DoubleLE (..)   , Word16BE (..)   , Int16BE (..)   , Word24BE (..)   , Int24BE (..)   , Word32BE (..)   , Int32BE (..)+  , Word64BE (..)+  , Int64BE (..)   , FloatBE (..)+  , DoubleBE (..)   ) where -import Dahdit.Internal-  ( ViaFromIntegral (..)-  , mkFloatLE-  , mkWord16LE-  , mkWord24LE-  , mkWord32LE-  , swapEndian-  , unMkFloatLE-  , unMkWord16LE-  , unMkWord24LE-  , unMkWord32LE-  )-import Dahdit.LiftedPrim (LiftedPrim (..))-import Data.Bits (Bits (..))+import Dahdit.Internal (EndianPair (..), swapEndian)+import Data.Bits (Bits) import Data.Default (Default (..))-import Data.Int (Int16, Int32, Int8)-import Data.Primitive.ByteArray (indexByteArray, writeByteArray)-import Data.Primitive.Types (Prim (..))-import Data.Proxy (Proxy (..))+import Data.Int (Int16, Int32, Int64) import Data.ShortWord (Int24, Word24)-import Data.Word (Word16, Word32, Word8)--class (Num le, Num be) => EndianPair le be | le -> be, be -> le where-  toLittleEndian :: be -> le-  toBigEndian :: le -> be+import Data.Word (Word16, Word32, Word64)  newtype Word16LE = Word16LE {unWord16LE :: Word16}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim)--instance LiftedPrim Word16LE where-  elemSizeLifted _ = 2--  indexByteArrayLiftedInBytes arr pos =-    let !b0 = indexByteArray arr pos-        !b1 = indexByteArray arr (pos + 1)-    in  Word16LE (mkWord16LE b0 b1)--  writeByteArrayLiftedInBytes w arr pos =-    let !(b0, b1) = unMkWord16LE (unWord16LE w)-    in  writeByteArray arr pos b0 *> writeByteArray arr (pos + 1) b1+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Int16LE = Int16LE {unInt16LE :: Int16}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim)-  deriving (LiftedPrim) via (ViaFromIntegral Word16LE Int16LE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Word24LE = Word24LE {unWord24LE :: Word24}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits)  instance Default Word24LE where   def = 0 -instance LiftedPrim Word24LE where-  elemSizeLifted _ = 3--  indexByteArrayLiftedInBytes arr pos =-    let !b0 = indexByteArray arr pos-        !b1 = indexByteArray arr (pos + 1)-        !b2 = indexByteArray arr (pos + 2)-    in  Word24LE (mkWord24LE b0 b1 b2)--  writeByteArrayLiftedInBytes w arr pos = do-    let !(b0, b1, b2) = unMkWord24LE (unWord24LE w)-    writeByteArray arr pos b0-    writeByteArray arr (pos + 1) b1-    writeByteArray arr (pos + 2) b2- newtype Int24LE = Int24LE {unInt24LE :: Int24}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits)-  deriving (LiftedPrim) via (ViaFromIntegral Word24LE Int24LE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits)  instance Default Int24LE where   def = 0  newtype Word32LE = Word32LE {unWord32LE :: Word32}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim)--instance LiftedPrim Word32LE where-  elemSizeLifted _ = 4--  indexByteArrayLiftedInBytes arr pos =-    let !b0 = indexByteArray arr pos-        !b1 = indexByteArray arr (pos + 1)-        !b2 = indexByteArray arr (pos + 2)-        !b3 = indexByteArray arr (pos + 3)-    in  Word32LE (mkWord32LE b0 b1 b2 b3)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -  writeByteArrayLiftedInBytes w arr pos = do-    let !(b0, b1, b2, b3) = unMkWord32LE (unWord32LE w)-    writeByteArray arr pos b0-    writeByteArray arr (pos + 1) b1-    writeByteArray arr (pos + 2) b2-    writeByteArray arr (pos + 3) b3+newtype Word64LE = Word64LE {unWord64LE :: Word64}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Int32LE = Int32LE {unInt32LE :: Int32}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim)-  deriving (LiftedPrim) via (ViaFromIntegral Word32LE Int32LE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -newtype FloatLE = FloatLE {unFloatLE :: Float}+newtype Int64LE = Int64LE {unInt64LE :: Int64}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default, Prim)--instance LiftedPrim FloatLE where-  elemSizeLifted _ = 4+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -  indexByteArrayLiftedInBytes arr pos =-    let !b0 = indexByteArray arr pos-        !b1 = indexByteArray arr (pos + 1)-        !b2 = indexByteArray arr (pos + 2)-        !b3 = indexByteArray arr (pos + 3)-    in  FloatLE (mkFloatLE b0 b1 b2 b3)+newtype FloatLE = FloatLE {unFloatLE :: Float}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default) -  writeByteArrayLiftedInBytes f arr pos = do-    let !(b0, b1, b2, b3) = unMkFloatLE (unFloatLE f)-    writeByteArray arr pos b0-    writeByteArray arr (pos + 1) b1-    writeByteArray arr (pos + 2) b2-    writeByteArray arr (pos + 3) b3+newtype DoubleLE = DoubleLE {unDoubleLE :: Double}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default)  newtype Word16BE = Word16BE {unWord16BE :: Word16}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default)-  deriving (LiftedPrim) via (ViaEndianPair Word16LE Word16BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Int16BE = Int16BE {unInt16BE :: Int16}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default)-  deriving (LiftedPrim) via (ViaEndianPair Int16LE Int16BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Word24BE = Word24BE {unWord24BE :: Word24}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits)-  deriving (LiftedPrim) via (ViaEndianPair Word24LE Word24BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits)  instance Default Word24BE where   def = 0  newtype Int24BE = Int24BE {unInt24BE :: Int24}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits)-  deriving (LiftedPrim) via (ViaEndianPair Int24LE Int24BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits)  instance Default Int24BE where   def = 0  newtype Word32BE = Word32BE {unWord32BE :: Word32}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default)-  deriving (LiftedPrim) via (ViaEndianPair Word32LE Word32BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default)  newtype Int32BE = Int32BE {unInt32BE :: Int32}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default)-  deriving (LiftedPrim) via (ViaEndianPair Int32LE Int32BE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -newtype FloatBE = FloatBE {unFloatBE :: Float}+newtype Word64BE = Word64BE {unWord64BE :: Word64}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default, Prim)-  deriving (LiftedPrim) via (ViaEndianPair FloatLE FloatBE)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -instance EndianPair Word8 Word8 where-  toLittleEndian = id-  toBigEndian = id+newtype Int64BE = Int64BE {unInt64BE :: Int64}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Enum, Bounded, Real, Integral, Bits, Default) -instance EndianPair Int8 Int8 where-  toLittleEndian = id-  toBigEndian = id+newtype FloatBE = FloatBE {unFloatBE :: Float}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default) +newtype DoubleBE = DoubleBE {unDoubleBE :: Double}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default)+ instance EndianPair Word16LE Word16BE where   toLittleEndian = Word16LE . swapEndian . unWord16BE   toBigEndian = Word16BE . swapEndian . unWord16LE@@ -219,13 +150,18 @@   toLittleEndian = Int32LE . swapEndian . unInt32BE   toBigEndian = Int32BE . swapEndian . unInt32LE +instance EndianPair Word64LE Word64BE where+  toLittleEndian = Word64LE . swapEndian . unWord64BE+  toBigEndian = Word64BE . swapEndian . unWord64LE++instance EndianPair Int64LE Int64BE where+  toLittleEndian = Int64LE . swapEndian . unInt64BE+  toBigEndian = Int64BE . swapEndian . unInt64LE+ instance EndianPair FloatLE FloatBE where   toLittleEndian = FloatLE . swapEndian . unFloatBE   toBigEndian = FloatBE . swapEndian . unFloatLE -newtype ViaEndianPair le be = ViaEndianPair {unViaEndianPair :: be}--instance (LiftedPrim le, EndianPair le be) => LiftedPrim (ViaEndianPair le be) where-  elemSizeLifted _ = elemSizeLifted (Proxy :: Proxy le)-  indexByteArrayLiftedInBytes arr pos = ViaEndianPair (toBigEndian (indexByteArrayLiftedInBytes arr pos))-  writeByteArrayLiftedInBytes (ViaEndianPair bval) = writeByteArrayLiftedInBytes (toLittleEndian bval)+instance EndianPair DoubleLE DoubleBE where+  toLittleEndian = DoubleLE . swapEndian . unDoubleBE+  toBigEndian = DoubleBE . swapEndian . unDoubleLE

@@ -1,22 +1,20 @@ module Dahdit.Run   ( GetError (..)   , prettyGetError-  , runGet-  , runGetIO-  , runGetFile+  , runGetInternal   , runCount-  , runPut-  , runPutFile+  , runPutInternal   ) where  import Control.Applicative (Alternative (..))-import Control.Exception (Exception (..), throwIO)+import Control.Exception (Exception (..), onException) import Control.Monad (replicateM_, unless) import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) import Control.Monad.Free.Church (F (..)) 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)@@ -37,9 +35,12 @@   , PutStaticSeqF (..)   , ScopeMode (..)   )-import Dahdit.LiftedPrim (LiftedPrim (..))+import Dahdit.LiftedPrimArray (LiftedPrimArray (..), sizeofLiftedPrimArray)+import Dahdit.Mem (ReadMem (..), WriteMem (..), readSBSMem, writeSBSMem) import Dahdit.Nums-  ( FloatBE+  ( DoubleBE+  , DoubleLE+  , FloatBE   , FloatLE   , Int16BE   , Int16LE (..)@@ -47,62 +48,43 @@   , Int24LE   , Int32BE   , Int32LE+  , Int64BE+  , Int64LE   , Word16BE   , Word16LE (..)   , Word24BE   , Word24LE   , Word32BE   , Word32LE+  , Word64BE+  , Word64LE   ) import Dahdit.Proxy (proxyForF)-import Dahdit.Sizes (ByteCount (..), staticByteSize)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Short as BSS-import Data.ByteString.Short.Internal (ShortByteString (..))+import Dahdit.Sizes (ByteCount (..), ElemCount (..), staticByteSize)+import Data.Coerce (coerce) import Data.Foldable (for_, toList) import Data.Int (Int8) import Data.Maybe (fromJust)-import Data.Primitive.ByteArray-  ( ByteArray (..)-  , MutableByteArray-  , cloneByteArray-  , copyByteArray-  , indexByteArray-  , newByteArray-  , setByteArray-  , unsafeFreezeByteArray-  , writeByteArray-  )-import Data.Primitive.PrimArray (PrimArray (..), sizeofPrimArray) import Data.STRef.Strict (STRef, newSTRef, readSTRef, writeSTRef) import qualified Data.Sequence as Seq import Data.Word (Word8)  -- Sizes: -getStaticSeqSize :: GetStaticSeqF a -> Int-getStaticSeqSize (GetStaticSeqF ec g _) =-  let !z = fromIntegral (staticByteSize (proxyForF g))-  in  z * fromIntegral ec+getStaticSeqSize :: GetStaticSeqF a -> ByteCount+getStaticSeqSize (GetStaticSeqF ec g _) = staticByteSize (proxyForF g) * coerce ec -getStaticArraySize :: GetStaticArrayF a -> Int-getStaticArraySize (GetStaticArrayF n prox _) =-  let !z = fromIntegral (staticByteSize prox)-  in  z * fromIntegral n+getStaticArraySize :: GetStaticArrayF a -> ByteCount+getStaticArraySize (GetStaticArrayF n prox _) = staticByteSize prox * coerce n -putStaticSeqSize :: PutStaticSeqF a -> Int-putStaticSeqSize (PutStaticSeqF n _ _ s _) =-  let !z = fromIntegral (staticByteSize (proxyForF s))-  in  z * fromIntegral n+putStaticSeqSize :: PutStaticSeqF a -> ByteCount+putStaticSeqSize (PutStaticSeqF n _ _ s _) = staticByteSize (proxyForF s) * coerce n -putStaticArrayElemSize :: PutStaticArrayF a -> Int-putStaticArrayElemSize (PutStaticArrayF _ _ a _) =-  fromIntegral (staticByteSize (proxyForF a))+putStaticArrayElemSize :: PutStaticArrayF a -> ByteCount+putStaticArrayElemSize (PutStaticArrayF _ _ a _) = staticByteSize (proxyForF a) -putStaticArraySize :: PutStaticArrayF a -> Int-putStaticArraySize (PutStaticArrayF n _ a _) =-  let !z = fromIntegral (staticByteSize (proxyForF a))-  in  z * fromIntegral n+putStaticArraySize :: PutStaticArrayF a -> ByteCount+putStaticArraySize (PutStaticArrayF n _ a _) = staticByteSize (proxyForF a) * coerce n  -- Get: @@ -121,283 +103,273 @@   GetErrorScopedMismatch ac bc -> "Did not parse enough scoped input (read " ++ show (unByteCount ac) ++ " bytes, expected " ++ show (unByteCount bc) ++ ")"   GetErrorFail msg -> "User error: " ++ msg -data GetEnv s = GetEnv-  { geLen :: !Int-  , gePos :: !(STRef s Int)-  , geArray :: !ByteArray+data GetEnv s r = GetEnv+  { geOff :: !(STRef s ByteCount)+  -- ^ Offset from buffer start (in bytes)+  , geCap :: !ByteCount+  -- ^ Capacity of buffer segment+  , geArray :: !r+  -- ^ Source buffer   } -newGetEnv :: ShortByteString -> ST s (GetEnv s)-newGetEnv sbs@(SBS arr) = do-  let !len = BSS.length sbs-  pos <- newSTRef 0-  pure $! GetEnv len pos (ByteArray arr)+newGetEnv :: ByteCount -> ByteCount -> r -> ST s (GetEnv s r)+newGetEnv off cap mem = do+  offRef <- newSTRef off+  pure (GetEnv offRef cap mem) -newtype GetEff s a = GetEff {unGetEff :: ReaderT (GetEnv s) (ExceptT GetError (ST s)) a}-  deriving newtype (Functor, Applicative, Monad, MonadReader (GetEnv s), MonadError GetError)+newtype GetEff s r a = GetEff {unGetEff :: ReaderT (GetEnv s r) (ExceptT GetError (ST s)) a}+  deriving newtype (Functor, Applicative, Monad, MonadReader (GetEnv s r), MonadError GetError) -runGetEff :: GetEff s a -> GetEnv s -> ST s (Either GetError a)-runGetEff m l = runExceptT (runReaderT (unGetEff m) l)+runGetEff :: GetEff s r a -> GetEnv s r -> ST s (Either GetError a)+runGetEff act env = runExceptT (runReaderT (unGetEff act) env) -instance MonadFail (GetEff s) where+instance MonadFail (GetEff s r) where   fail = GetEff . throwError . GetErrorFail -stGetEff :: ST s a -> GetEff s a+stGetEff :: ST s a -> GetEff s r a stGetEff = GetEff . lift . lift -newtype GetRun s a = GetRun {unGetRun :: FreeT GetF (GetEff s) a}+newtype GetRun s r a = GetRun {unGetRun :: FreeT GetF (GetEff s r) a}   deriving newtype (Functor, Applicative, Monad) -guardReadBytes :: String -> Int -> GetEff s Int+guardReadBytes :: String -> ByteCount -> GetEff s r ByteCount guardReadBytes nm bc = do-  GetEnv l posRef _ <- ask-  pos <- stGetEff (readSTRef posRef)-  let !ac = l - pos+  GetEnv offRef cap _ <- ask+  off <- stGetEff (readSTRef offRef)+  let ac = cap - off   if bc > ac-    then throwError (GetErrorParseNeed nm (fromIntegral ac) (fromIntegral bc))-    else pure pos+    then throwError (GetErrorParseNeed nm ac bc)+    else pure off -readBytes :: String -> Int -> (ByteArray -> Int -> a) -> GetEff s a+readBytes :: String -> ByteCount -> (r -> ByteCount -> a) -> GetEff s r a readBytes nm bc f = do-  pos <- guardReadBytes nm bc-  GetEnv _ posRef arr <- ask+  off <- guardReadBytes nm bc+  GetEnv offRef _ mem <- ask   stGetEff $ do-    let !a = f arr pos-        !newPos = pos + bc-    writeSTRef posRef newPos+    let a = f mem off+        newOff = off + bc+    writeSTRef offRef newOff     pure a -readShortByteString :: Int -> ByteArray -> Int -> ShortByteString-readShortByteString len arr pos = let !(ByteArray frozArr) = cloneByteArray arr pos len in SBS frozArr--readScope :: GetScopeF (GetEff s a) -> GetEff s a+readScope :: ReadMem r => GetScopeF (GetEff s r a) -> GetEff s r a readScope (GetScopeF sm bc g k) = do-  let intBc = fromIntegral bc-  GetEnv oldLen posRef _ <- ask-  oldPos <- stGetEff (readSTRef posRef)-  let !oldAvail = oldLen - oldPos-  if intBc > oldAvail-    then throwError (GetErrorParseNeed "scope" (fromIntegral oldAvail) bc)+  GetEnv offRef oldCap _ <- ask+  oldOff <- stGetEff (readSTRef offRef)+  let oldAvail = oldCap - oldOff+  if bc > oldAvail+    then throwError (GetErrorParseNeed "scope" oldAvail bc)     else do-      let !newLen = oldPos + intBc-      a <- local (\ge -> ge {geLen = newLen}) (mkGetEff g)+      let newCap = oldOff + bc+      a <- local (\ge -> ge {geCap = newCap}) (mkGetEff g)       case sm of         ScopeModeWithin -> k a         ScopeModeExact -> do-          newPos <- stGetEff (readSTRef posRef)-          let !actualBc = newPos - oldPos-          if actualBc == intBc+          newOff <- stGetEff (readSTRef offRef)+          let actualBc = newOff - oldOff+          if actualBc == bc             then k a-            else throwError (GetErrorScopedMismatch (fromIntegral actualBc) bc)+            else throwError (GetErrorScopedMismatch actualBc bc) -readStaticSeq :: GetStaticSeqF (GetEff s a) -> GetEff s a+readStaticSeq :: ReadMem r => GetStaticSeqF (GetEff s r a) -> GetEff s r a readStaticSeq gss@(GetStaticSeqF ec g k) = do-  let !bc = getStaticSeqSize gss+  let bc = getStaticSeqSize gss   _ <- guardReadBytes "static sequence" bc-  ss <- Seq.replicateA (fromIntegral ec) (mkGetEff g)+  ss <- Seq.replicateA (coerce ec) (mkGetEff g)   k ss -readStaticArray :: GetStaticArrayF (GetEff s a) -> GetEff s a+readStaticArray :: ReadMem r => GetStaticArrayF (GetEff s r a) -> GetEff s r a readStaticArray gsa@(GetStaticArrayF _ _ k) = do-  let !bc = getStaticArraySize gsa-  sa <- readBytes "static vector" bc (\arr pos -> let !(ByteArray frozArr) = cloneByteArray arr pos bc in PrimArray frozArr)-  k sa+  let bc = getStaticArraySize gsa+  sa <- readBytes "static vector" bc (\mem off -> cloneArrayMemInBytes mem off bc)+  k (LiftedPrimArray sa) -readLookAhead :: GetLookAheadF (GetEff s a) -> GetEff s a+readLookAhead :: ReadMem r => GetLookAheadF (GetEff s r a) -> GetEff s r a readLookAhead (GetLookAheadF g k) = do-  posRef <- asks gePos-  startPos <- stGetEff (readSTRef posRef)+  offRef <- asks geOff+  startOff <- stGetEff (readSTRef offRef)   a <- mkGetEff g-  stGetEff (writeSTRef posRef startPos)+  stGetEff (writeSTRef offRef startOff)   k a -execGetRun :: GetF (GetEff s a) -> GetEff s a+execGetRun :: ReadMem r => GetF (GetEff s r a) -> GetEff s r a execGetRun = \case-  GetFWord8 k -> readBytes "Word8" 1 (indexByteArray @Word8) >>= k-  GetFInt8 k -> readBytes "Int8" 1 (indexByteArray @Int8) >>= k-  GetFWord16LE k -> readBytes "Word16LE" 2 (indexByteArrayLiftedInBytes @Word16LE) >>= k-  GetFInt16LE k -> readBytes "Int16LE" 2 (indexByteArrayLiftedInBytes @Int16LE) >>= k-  GetFWord24LE k -> readBytes "Word24LE" 3 (indexByteArrayLiftedInBytes @Word24LE) >>= k-  GetFInt24LE k -> readBytes "Int24LE" 3 (indexByteArrayLiftedInBytes @Int24LE) >>= k-  GetFWord32LE k -> readBytes "Word32LE" 4 (indexByteArrayLiftedInBytes @Word32LE) >>= k-  GetFInt32LE k -> readBytes "Int32LE" 4 (indexByteArrayLiftedInBytes @Int32LE) >>= k-  GetFFloatLE k -> readBytes "FloatLE" 4 (indexByteArrayLiftedInBytes @FloatLE) >>= k-  GetFWord16BE k -> readBytes "Word16BE" 2 (indexByteArrayLiftedInBytes @Word16BE) >>= k-  GetFInt16BE k -> readBytes "Int16BE" 2 (indexByteArrayLiftedInBytes @Int16BE) >>= k-  GetFWord24BE k -> readBytes "Word24BE" 3 (indexByteArrayLiftedInBytes @Word24BE) >>= k-  GetFInt24BE k -> readBytes "Int24BE" 3 (indexByteArrayLiftedInBytes @Int24BE) >>= k-  GetFWord32BE k -> readBytes "Word32BE" 4 (indexByteArrayLiftedInBytes @Word32BE) >>= k-  GetFInt32BE k -> readBytes "Int32BE" 4 (indexByteArrayLiftedInBytes @Int32BE) >>= k-  GetFFloatBE k -> readBytes "FloatBE" 4 (indexByteArrayLiftedInBytes @FloatBE) >>= k+  GetFWord8 k -> readBytes "Word8" 1 (indexMemInBytes @_ @Word8) >>= k+  GetFInt8 k -> readBytes "Int8" 1 (indexMemInBytes @_ @Int8) >>= k+  GetFWord16LE k -> readBytes "Word16LE" 2 (indexMemInBytes @_ @Word16LE) >>= k+  GetFInt16LE k -> readBytes "Int16LE" 2 (indexMemInBytes @_ @Int16LE) >>= k+  GetFWord24LE k -> readBytes "Word24LE" 3 (indexMemInBytes @_ @Word24LE) >>= k+  GetFInt24LE k -> readBytes "Int24LE" 3 (indexMemInBytes @_ @Int24LE) >>= k+  GetFWord32LE k -> readBytes "Word32LE" 4 (indexMemInBytes @_ @Word32LE) >>= k+  GetFInt32LE k -> readBytes "Int32LE" 4 (indexMemInBytes @_ @Int32LE) >>= k+  GetFWord64LE k -> readBytes "Word64LE" 8 (indexMemInBytes @_ @Word64LE) >>= k+  GetFInt64LE k -> readBytes "Int64LE" 8 (indexMemInBytes @_ @Int64LE) >>= k+  GetFFloatLE k -> readBytes "FloatLE" 4 (indexMemInBytes @_ @FloatLE) >>= k+  GetFDoubleLE k -> readBytes "DoubleLE" 8 (indexMemInBytes @_ @DoubleLE) >>= k+  GetFWord16BE k -> readBytes "Word16BE" 2 (indexMemInBytes @_ @Word16BE) >>= k+  GetFInt16BE k -> readBytes "Int16BE" 2 (indexMemInBytes @_ @Int16BE) >>= k+  GetFWord24BE k -> readBytes "Word24BE" 3 (indexMemInBytes @_ @Word24BE) >>= k+  GetFInt24BE k -> readBytes "Int24BE" 3 (indexMemInBytes @_ @Int24BE) >>= k+  GetFWord32BE k -> readBytes "Word32BE" 4 (indexMemInBytes @_ @Word32BE) >>= k+  GetFInt32BE k -> readBytes "Int32BE" 4 (indexMemInBytes @_ @Int32BE) >>= k+  GetFWord64BE k -> readBytes "Word64BE" 8 (indexMemInBytes @_ @Word64BE) >>= k+  GetFInt64BE k -> readBytes "Int64BE" 8 (indexMemInBytes @_ @Int64BE) >>= k+  GetFFloatBE k -> readBytes "FloatBE" 4 (indexMemInBytes @_ @FloatBE) >>= k+  GetFDoubleBE k -> readBytes "DoubleBE" 8 (indexMemInBytes @_ @DoubleBE) >>= k   GetFShortByteString bc k ->-    let !len = fromIntegral bc-    in  readBytes "ShortByteString" len (readShortByteString len) >>= k+    readBytes "ShortByteString" bc (\mem off -> readSBSMem mem off bc) >>= k   GetFStaticSeq gss -> readStaticSeq gss   GetFStaticArray gsa -> readStaticArray gsa   GetFByteArray bc k ->-    let !len = fromIntegral bc-    in  readBytes "ByteArray" len (\arr pos -> cloneByteArray arr pos len) >>= k+    readBytes "ByteArray" bc (\mem off -> cloneArrayMemInBytes mem off bc) >>= k   GetFScope gs -> readScope gs-  GetFSkip bc k -> readBytes "skip" (fromIntegral bc) (\_ _ -> ()) *> k+  GetFSkip bc k -> readBytes "skip" bc (\_ _ -> ()) *> k   GetFLookAhead gla -> readLookAhead gla   GetFRemainingSize k -> do-    GetEnv len posRef _ <- ask-    pos <- stGetEff (readSTRef posRef)-    let !bc = fromIntegral (len - pos)-    k bc+    GetEnv offRef cap _ <- ask+    off <- stGetEff (readSTRef offRef)+    k (cap - off)   GetFFail msg -> fail msg -runGetRun :: GetRun s a -> GetEnv s -> ST s (Either GetError a)+runGetRun :: ReadMem r => GetRun s r a -> GetEnv s r -> ST s (Either GetError a) runGetRun = runGetEff . iterGetRun -iterGetRun :: GetRun s a -> GetEff s a-iterGetRun m = iterT execGetRun (unGetRun m)+iterGetRun :: ReadMem r => GetRun s r a -> GetEff s r a+iterGetRun act = iterT execGetRun (unGetRun act) -mkGetRun :: Get a -> GetRun s a+mkGetRun :: Get a -> GetRun s r a mkGetRun (Get (F w)) = GetRun (w pure wrap) -mkGetEff :: Get a -> GetEff s a+mkGetEff :: ReadMem r => Get a -> GetEff s r a mkGetEff = iterGetRun . mkGetRun -runGet :: Get a -> ShortByteString -> (Either GetError a, ByteCount)-runGet m bs = runST $ do-  let !n = mkGetEff m-  env <- newGetEnv bs-  ea <- runGetEff n env-  bc <- readSTRef (gePos env)-  pure (ea, fromIntegral bc)--runGetIO :: Get a -> ShortByteString -> IO (a, ByteCount)-runGetIO m bs =-  let (!ea, !bc) = runGet m bs-  in  case ea of-        Left e -> throwIO e-        Right a -> pure (a, bc)--runGetFile :: Get a -> FilePath -> IO (a, ByteCount)-runGetFile m fp = do-  bs <- BS.readFile fp-  let !bss = BSS.toShort bs-  runGetIO m bss+runGetInternal :: ReadMem r => ByteCount -> Get a -> ByteCount -> r -> (Either GetError a, ByteCount)+runGetInternal off act cap mem = runST $ do+  let eff = mkGetEff act+  env <- newGetEnv off cap mem+  ea <- runGetEff eff env+  bc <- readSTRef (geOff env)+  pure (ea, bc)  -- Put unsafe: -data PutEnv s = PutEnv-  { peLen :: !Int-  , pePos :: !(STRef s Int)-  , peArray :: !(MutableByteArray s)+data PutEnv s q = PutEnv+  { peOff :: !(STRef s ByteCount)+  -- ^ Offset in bytes from start of buffer+  , peCap :: !ByteCount+  -- ^ Capacity of buffer segment+  , peArray :: !(q s)+  -- ^ Destination buffer   } -newPutEnv :: Int -> ST s (PutEnv s)-newPutEnv len = PutEnv len <$> newSTRef 0 <*> newByteArray len+newPutEnv :: ByteCount -> q s -> ST s (PutEnv s q)+newPutEnv cap mem = do+  offRef <- newSTRef 0+  pure (PutEnv offRef cap mem) -newtype PutEff s a = PutEff {unPutEff :: ReaderT (PutEnv s) (ST s) a}-  deriving newtype (Functor, Applicative, Monad, MonadReader (PutEnv s))+newtype PutEff s q a = PutEff {unPutEff :: ReaderT (PutEnv s q) (ST s) a}+  deriving newtype (Functor, Applicative, Monad, MonadReader (PutEnv s q)) -runPutEff :: PutEff s a -> PutEnv s -> ST s a-runPutEff m = runReaderT (unPutEff m)+runPutEff :: PutEff s q a -> PutEnv s q -> ST s a+runPutEff act = runReaderT (unPutEff act) -stPutEff :: ST s a -> PutEff s a+stPutEff :: ST s a -> PutEff s q a stPutEff = PutEff . lift -newtype PutRun s a = PutRun {unPutRun :: FreeT PutF (PutEff s) a}+newtype PutRun s q a = PutRun {unPutRun :: FreeT PutF (PutEff s q) a}   deriving newtype (Functor, Applicative, Monad) -writeBytes :: Int -> (MutableByteArray s -> Int -> ST s ()) -> PutEff s ()+writeBytes :: ByteCount -> (q s -> ByteCount -> ST s ()) -> PutEff s q () writeBytes bc f = do-  PutEnv _ posRef arr <- ask+  PutEnv offRef _ mem <- ask   stPutEff $ do-    pos <- readSTRef posRef-    f arr pos-    let !newPos = pos + bc-    writeSTRef posRef newPos--writeShortByteString :: ShortByteString -> Int -> MutableByteArray s -> Int -> ST s ()-writeShortByteString (SBS frozArr) len arr pos = copyByteArray arr pos (ByteArray frozArr) 0 len+    off <- readSTRef offRef+    f mem off+    let newOff = off + bc+    writeSTRef offRef newOff -writeStaticSeq :: PutStaticSeqF (PutEff s a) -> PutEff s a+writeStaticSeq :: WriteMem q => PutStaticSeqF (PutEff s q a) -> PutEff s q a writeStaticSeq (PutStaticSeqF n mz p s k) = do-  let n' = fromIntegral n-  for_ (take n' (toList s)) $ \a -> do-    let !x = p a-    mkPutEff x-  let !e = Seq.length s-  unless (n' <= e) $ do-    let !q = mkPutEff (p (fromJust mz))-    replicateM_ (n' - e) q+  for_ (take (coerce n) (toList s)) $ \a -> do+    mkPutEff (p a)+  let e = Seq.length s+  unless (coerce n <= e) $ do+    let q = mkPutEff (p (fromJust mz))+    replicateM_ (coerce n - e) q   k -writeStaticArray :: PutStaticArrayF (PutEff s a) -> PutEff s a-writeStaticArray psa@(PutStaticArrayF needElems mz a@(PrimArray frozArr) k) = do-  let !elemSize = putStaticArrayElemSize psa-      !haveElems = sizeofPrimArray a-      !useElems = min haveElems (fromIntegral needElems)-      !useBc = elemSize * useElems-  writeBytes useBc (\arr pos -> copyByteArray arr pos (ByteArray frozArr) 0 useBc)-  let !needBc = putStaticArraySize psa+writeStaticArray :: WriteMem q => PutStaticArrayF (PutEff s q a) -> PutEff s q a+writeStaticArray psa@(PutStaticArrayF needElems mz a@(LiftedPrimArray ba) k) = do+  let elemSize = putStaticArrayElemSize psa+      haveElems = sizeofLiftedPrimArray a+      useElems = min haveElems (coerce needElems)+      useBc = elemSize * coerce useElems+  writeBytes useBc (copyArrayMemInBytes ba 0 useBc)+  let needBc = putStaticArraySize psa   unless (useBc == needBc) $ do-    let !extraBc = needBc - useBc-    writeBytes extraBc (\arr pos -> setByteArray arr (pos + useBc) (pos + extraBc) (fromJust mz))+    let extraBc = needBc - useBc+    case mz of+      Nothing -> error "no default element for undersized static array"+      Just z -> writeBytes extraBc (setMemInBytes extraBc z)   k -execPutRun :: PutF (PutEff s a) -> PutEff s a+execPutRun :: WriteMem q => PutF (PutEff s q a) -> PutEff s q a execPutRun = \case-  PutFWord8 x k -> writeBytes 1 (\arr pos -> writeByteArray arr pos x) *> k-  PutFInt8 x k -> writeBytes 1 (\arr pos -> writeByteArray arr pos x) *> k-  PutFWord16LE x k -> writeBytes 2 (writeByteArrayLiftedInBytes x) *> k-  PutFInt16LE x k -> writeBytes 2 (writeByteArrayLiftedInBytes x) *> k-  PutFWord24LE x k -> writeBytes 3 (writeByteArrayLiftedInBytes x) *> k-  PutFInt24LE x k -> writeBytes 3 (writeByteArrayLiftedInBytes x) *> k-  PutFWord32LE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k-  PutFInt32LE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k-  PutFFloatLE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k-  PutFWord16BE x k -> writeBytes 2 (writeByteArrayLiftedInBytes x) *> k-  PutFInt16BE x k -> writeBytes 2 (writeByteArrayLiftedInBytes x) *> k-  PutFWord24BE x k -> writeBytes 3 (writeByteArrayLiftedInBytes x) *> k-  PutFInt24BE x k -> writeBytes 3 (writeByteArrayLiftedInBytes x) *> k-  PutFWord32BE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k-  PutFInt32BE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k-  PutFFloatBE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k+  PutFWord8 x k -> writeBytes 1 (writeMemInBytes x) *> k+  PutFInt8 x k -> writeBytes 1 (writeMemInBytes x) *> k+  PutFWord16LE x k -> writeBytes 2 (writeMemInBytes x) *> k+  PutFInt16LE x k -> writeBytes 2 (writeMemInBytes x) *> k+  PutFWord24LE x k -> writeBytes 3 (writeMemInBytes x) *> k+  PutFInt24LE x k -> writeBytes 3 (writeMemInBytes x) *> k+  PutFWord32LE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFInt32LE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFWord64LE x k -> writeBytes 8 (writeMemInBytes x) *> k+  PutFInt64LE x k -> writeBytes 8 (writeMemInBytes x) *> k+  PutFFloatLE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFDoubleLE x k -> writeBytes 8 (writeMemInBytes x) *> k+  PutFWord16BE x k -> writeBytes 2 (writeMemInBytes x) *> k+  PutFInt16BE x k -> writeBytes 2 (writeMemInBytes x) *> k+  PutFWord24BE x k -> writeBytes 3 (writeMemInBytes x) *> k+  PutFInt24BE x k -> writeBytes 3 (writeMemInBytes x) *> k+  PutFWord32BE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFInt32BE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFWord64BE x k -> writeBytes 8 (writeMemInBytes x) *> k+  PutFInt64BE x k -> writeBytes 8 (writeMemInBytes x) *> k+  PutFFloatBE x k -> writeBytes 4 (writeMemInBytes x) *> k+  PutFDoubleBE x k -> writeBytes 8 (writeMemInBytes x) *> k   PutFShortByteString bc sbs k ->-    let !len = fromIntegral bc-    in  writeBytes len (writeShortByteString sbs len) *> k+    writeBytes bc (writeSBSMem sbs bc) *> k   PutFStaticSeq pss -> writeStaticSeq pss   PutFStaticArray psa -> writeStaticArray psa   PutFByteArray bc barr k ->-    let !len = fromIntegral bc-    in  writeBytes len (\arr pos -> copyByteArray arr pos barr 0 len) *> k+    writeBytes bc (copyArrayMemInBytes barr 0 bc) *> k   PutFStaticHint (PutStaticHintF _ p k) -> mkPutEff p *> k -runPutRun :: PutRun s a -> PutEnv s -> ST s a+runPutRun :: WriteMem q => PutRun s q a -> PutEnv s q -> ST s a runPutRun = runPutEff . iterPutRun -iterPutRun :: PutRun s a -> PutEff s a-iterPutRun m = iterT execPutRun (unPutRun m)+iterPutRun :: WriteMem q => PutRun s q a -> PutEff s q a+iterPutRun act = iterT execPutRun (unPutRun act) -mkPutRun :: PutM a -> PutRun s a+mkPutRun :: PutM a -> PutRun s q a mkPutRun (PutM (F w)) = PutRun (w pure wrap) -mkPutEff :: PutM a -> PutEff s a+mkPutEff :: WriteMem q => PutM a -> PutEff s q a mkPutEff = iterPutRun . mkPutRun -runPutUnsafe :: Put -> ByteCount -> ShortByteString-runPutUnsafe m bc = runST $ do-  let !len = fromIntegral bc-      !n = mkPutRun m-  st@(PutEnv _ posRef arr) <- newPutEnv len-  runPutRun n st-  pos <- readSTRef posRef-  unless (pos == len) (error ("Invalid put length: (given " ++ show len ++ ", used " ++ show pos ++ ")"))-  ByteArray frozArr <- unsafeFreezeByteArray arr-  pure $! SBS frozArr+runPutUnsafe :: WriteMem q => Put -> ByteCount -> q s -> ST s ByteCount+runPutUnsafe act len mem = do+  let eff = mkPutRun act+  st@(PutEnv offRef _ _) <- newPutEnv len mem+  runPutRun eff st+  readSTRef offRef  -- Count: -newtype CountEff a = CountEff {unCountEff :: MaybeT (State Int) a}-  deriving newtype (Functor, Applicative, Monad, Alternative, MonadState Int)+newtype CountEff a = CountEff {unCountEff :: MaybeT (State ByteCount) a}+  deriving newtype (Functor, Applicative, Monad, Alternative, MonadState ByteCount) -runCountEff :: CountEff a -> Int -> (Maybe a, Int)-runCountEff m = runState (runMaybeT (unCountEff m))+runCountEff :: CountEff a -> ByteCount -> (Maybe a, ByteCount)+runCountEff act = runState (runMaybeT (unCountEff act))  newtype CountRun a = CountRun {unCountRun :: FreeT PutF CountEff a}   deriving newtype (Functor, Applicative, Monad)@@ -412,35 +384,35 @@   PutFInt24LE _ k -> State.modify' (3 +) *> k   PutFWord32LE _ k -> State.modify' (4 +) *> k   PutFInt32LE _ k -> State.modify' (4 +) *> k+  PutFWord64LE _ k -> State.modify' (8 +) *> k+  PutFInt64LE _ k -> State.modify' (8 +) *> k   PutFFloatLE _ k -> State.modify' (4 +) *> k+  PutFDoubleLE _ k -> State.modify' (8 +) *> k   PutFWord16BE _ k -> State.modify' (2 +) *> k   PutFInt16BE _ k -> State.modify' (2 +) *> k   PutFWord24BE _ k -> State.modify' (3 +) *> k   PutFInt24BE _ k -> State.modify' (3 +) *> k   PutFWord32BE _ k -> State.modify' (4 +) *> k   PutFInt32BE _ k -> State.modify' (4 +) *> k+  PutFWord64BE _ k -> State.modify' (8 +) *> k+  PutFInt64BE _ k -> State.modify' (8 +) *> k   PutFFloatBE _ k -> State.modify' (4 +) *> k-  PutFShortByteString bc _ k ->-    let !len = fromIntegral bc-    in  State.modify' (len +) *> k+  PutFDoubleBE _ k -> State.modify' (8 +) *> k+  PutFShortByteString bc _ k -> State.modify' (bc +) *> k   PutFStaticSeq pss@(PutStaticSeqF _ _ _ _ k) ->-    let !len = putStaticSeqSize pss-    in  State.modify' (len +) *> k+    let bc = putStaticSeqSize pss+    in  State.modify' (bc +) *> k   PutFStaticArray psv@(PutStaticArrayF _ _ _ k) ->-    let !len = putStaticArraySize psv-    in  State.modify' (len +) *> k-  PutFByteArray bc _ k ->-    let !len = fromIntegral bc-    in  State.modify' (len +) *> k-  PutFStaticHint (PutStaticHintF bc _ k) ->-    let !len = fromIntegral bc-    in  State.modify' (len +) *> k+    let bc = putStaticArraySize psv+    in  State.modify' (bc +) *> k+  PutFByteArray bc _ k -> State.modify' (bc +) *> k+  PutFStaticHint (PutStaticHintF bc _ k) -> State.modify' (bc +) *> k -runCountRun :: CountRun a -> Int -> (Maybe a, Int)+runCountRun :: CountRun a -> ByteCount -> (Maybe a, ByteCount) runCountRun = runCountEff . iterCountRun  iterCountRun :: CountRun a -> CountEff a-iterCountRun m = iterT execCountRun (unCountRun m)+iterCountRun act = iterT execCountRun (unCountRun act)  mkCountRun :: PutM a -> CountRun a mkCountRun (PutM (F w)) = CountRun (w pure wrap)@@ -449,20 +421,16 @@ mkCountEff = iterCountRun . mkCountRun  runCount :: Put -> ByteCount-runCount m =-  let !n = mkCountRun m-      (_, !bc) = runCountRun n 0-  in  fromIntegral bc+runCount act =+  let eff = mkCountRun act+      (_, bc) = runCountRun eff 0+  in  bc  -- Put safe: -runPut :: Put -> ShortByteString-runPut m = let !bc = runCount m in runPutUnsafe m bc---- Put file:--runPutFile :: FilePath -> Put -> IO ()-runPutFile fp m =-  let !bs = runPut m-      !bs' = BSS.fromShort bs-  in  BS.writeFile fp bs'+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)

@@ -1,18 +1,20 @@ module Dahdit.Sizes-  ( ElementCount (..)-  , ByteCount (..)-  , StaticByteSized (..)-  , byteSizeViaStatic+  ( ByteCount (..)+  , ElemCount (..)   , ByteSized (..)+  , StaticByteSized (..)   , ViaStaticByteSized (..)   , byteSizeFoldable   , staticByteSizeFoldable+  , byteSizeViaStatic   ) where -import Dahdit.LiftedPrim (LiftedPrim, LiftedPrimArray, sizeofLiftedPrimArray)+import Dahdit.Internal (ViaEndianPair (..), ViaFromIntegral (..)) import Dahdit.Nums-  ( FloatBE+  ( DoubleBE+  , DoubleLE+  , FloatBE   , FloatLE   , Int16BE   , Int16LE@@ -20,35 +22,50 @@   , Int24LE   , Int32BE   , Int32LE+  , Int64BE+  , Int64LE   , Word16BE   , Word16LE   , Word24BE   , Word24LE   , Word32BE   , Word32LE+  , Word64BE+  , Word64LE   ) import Dahdit.Proxy (proxyFor, proxyForF) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS+import Data.Coerce (coerce) import Data.Default (Default) import Data.Foldable (foldMap') import Data.Int (Int16, Int32, Int64, Int8)-import Data.Primitive (Prim)-import Data.Primitive.PrimArray (PrimArray, sizeofPrimArray)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) import Data.Semigroup (Sum (..)) import Data.Sequence (Seq)-import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.ShortWord (Int24, Word24) import Data.Word (Word16, Word32, Word64, Word8) -newtype ElementCount = ElementCount {unElementCount :: Word64}+-- Counts++newtype ByteCount = ByteCount {unByteCount :: Int}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bounded, Default)+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Default) -newtype ByteCount = ByteCount {unByteCount :: Word64}+newtype ElemCount = ElemCount {unElemCount :: Int}   deriving stock (Show)-  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bounded, Default)+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Default) +-- ByteSized+ class ByteSized a where   byteSize :: a -> ByteCount @@ -67,6 +84,12 @@ instance ByteSized Int16 where   byteSize _ = 2 +instance ByteSized Word24 where+  byteSize _ = 3++instance ByteSized Int24 where+  byteSize _ = 3+ instance ByteSized Word32 where   byteSize _ = 4 @@ -79,6 +102,21 @@ instance ByteSized Int64 where   byteSize _ = 8 +instance ByteSized Float where+  byteSize _ = 4++instance ByteSized Double where+  byteSize _ = 8++instance ByteSized Bool where+  byteSize _ = 1++instance ByteSized Char where+  byteSize _ = 1++instance ByteSized Int where+  byteSize _ = 8+ instance ByteSized Word16LE where   byteSize _ = 2 @@ -97,57 +135,92 @@ instance ByteSized Int32LE where   byteSize _ = 4 +instance ByteSized Word64LE where+  byteSize _ = 8++instance ByteSized Int64LE where+  byteSize _ = 8+ instance ByteSized FloatLE where   byteSize _ = 4 -instance ByteSized Word16BE where-  byteSize _ = 2+instance ByteSized DoubleLE where+  byteSize _ = 8 -instance ByteSized Int16BE where-  byteSize _ = 2+instance StaticByteSized x => ByteSized (ViaFromIntegral x y) where+  byteSize = byteSizeViaStatic -instance ByteSized Word24BE where-  byteSize _ = 3+instance StaticByteSized le => ByteSized (ViaEndianPair le be) where+  byteSize = byteSizeViaStatic -instance ByteSized Int24BE where-  byteSize _ = 3+deriving via (ViaEndianPair Word16LE Word16BE) instance ByteSized Word16BE -instance ByteSized Word32BE where-  byteSize _ = 4+deriving via (ViaEndianPair Int16LE Int16BE) instance ByteSized Int16BE -instance ByteSized Int32BE where-  byteSize _ = 4+deriving via (ViaEndianPair Word24LE Word24BE) instance ByteSized Word24BE -instance ByteSized FloatBE where-  byteSize _ = 4+deriving via (ViaEndianPair Int24LE Int24BE) instance ByteSized Int24BE +deriving via (ViaEndianPair Word32LE Word32BE) instance ByteSized Word32BE++deriving via (ViaEndianPair Int32LE Int32BE) instance ByteSized Int32BE++deriving via (ViaEndianPair Word64LE Word64BE) instance ByteSized Word64BE++deriving via (ViaEndianPair Int64LE Int64BE) instance ByteSized Int64BE++deriving via (ViaEndianPair FloatLE FloatBE) instance ByteSized FloatBE++deriving via (ViaEndianPair DoubleLE DoubleBE) instance ByteSized DoubleBE+ instance ByteSized ShortByteString where-  byteSize = fromIntegral . BSS.length+  byteSize = coerce . BSS.length -instance StaticByteSized a => ByteSized (Seq a) where-  byteSize ss =-    let !elen = staticByteSize (Proxy :: Proxy a)-        !alen = fromIntegral (Seq.length ss)-    in  elen * alen+instance ByteSized a => ByteSized [a] where+  byteSize = byteSizeFoldable -instance (StaticByteSized a, Prim a) => ByteSized (PrimArray a) where-  byteSize pa =-    let !elen = staticByteSize (Proxy :: Proxy a)-        !alen = fromIntegral (sizeofPrimArray pa)-    in  elen * alen+instance ByteSized a => ByteSized (Seq a) where+  byteSize = byteSizeFoldable -instance (StaticByteSized a, LiftedPrim a) => ByteSized (LiftedPrimArray a) where-  byteSize lpa =-    let !elen = staticByteSize (Proxy :: Proxy a)-        !alen = fromIntegral (sizeofLiftedPrimArray lpa)-    in  elen * alen+instance ByteSized a => ByteSized (Maybe a) where+  byteSize = \case+    Nothing -> 1+    Just a -> 1 + byteSize a +instance (ByteSized b, ByteSized a) => ByteSized (Either b a) where+  byteSize = \case+    Left b -> 1 + byteSize b+    Right a -> 1 + byteSize a++instance (ByteSized a, ByteSized b) => ByteSized (a, b) where+  byteSize (a, b) = byteSize a + byteSize b++instance (ByteSized a, ByteSized b, ByteSized c) => ByteSized (a, b, c) where+  byteSize (a, b, c) = byteSize a + byteSize b + byteSize c++instance (ByteSized a, ByteSized b, ByteSized c, ByteSized d) => ByteSized (a, b, c, d) where+  byteSize (a, b, c, d) = byteSize a + byteSize b + byteSize c + byteSize d++instance (ByteSized a, ByteSized b, ByteSized c, ByteSized d, ByteSized e) => ByteSized (a, b, c, d, e) where+  byteSize (a, b, c, d, e) = byteSize a + byteSize b + byteSize c + byteSize d + byteSize e++instance ByteSized a => ByteSized (Set a) where+  byteSize = byteSize . Set.toAscList++instance (ByteSized k, ByteSized v) => ByteSized (Map k v) where+  byteSize = byteSize . Map.toAscList++instance ByteSized IntSet where+  byteSize = byteSize . IntSet.toAscList++instance ByteSized v => ByteSized (IntMap v) where+  byteSize = byteSize . IntMap.toAscList++-- StaticByteSized+ class ByteSized a => StaticByteSized a where   staticByteSize :: Proxy a -> ByteCount -byteSizeViaStatic :: StaticByteSized a => a -> ByteCount-byteSizeViaStatic = staticByteSize . proxyFor- instance StaticByteSized () where   staticByteSize _ = 0 @@ -163,6 +236,12 @@ instance StaticByteSized Int16 where   staticByteSize _ = 2 +instance StaticByteSized Word24 where+  staticByteSize _ = 3++instance StaticByteSized Int24 where+  staticByteSize _ = 3+ instance StaticByteSized Word32 where   staticByteSize _ = 4 @@ -175,6 +254,21 @@ instance StaticByteSized Int64 where   staticByteSize _ = 8 +instance StaticByteSized Float where+  staticByteSize _ = 4++instance StaticByteSized Double where+  staticByteSize _ = 8++instance StaticByteSized Bool where+  staticByteSize _ = 1++instance StaticByteSized Char where+  staticByteSize _ = 1++instance StaticByteSized Int where+  staticByteSize _ = 8+ instance StaticByteSized Word16LE where   staticByteSize _ = 2 @@ -193,30 +287,46 @@ instance StaticByteSized Int32LE where   staticByteSize _ = 4 +instance StaticByteSized Word64LE where+  staticByteSize _ = 8++instance StaticByteSized Int64LE where+  staticByteSize _ = 8+ instance StaticByteSized FloatLE where   staticByteSize _ = 4 -instance StaticByteSized Word16BE where-  staticByteSize _ = 2+instance StaticByteSized DoubleLE where+  staticByteSize _ = 8 -instance StaticByteSized Int16BE where-  staticByteSize _ = 2+instance StaticByteSized x => StaticByteSized (ViaFromIntegral x y) where+  staticByteSize _ = staticByteSize (Proxy :: Proxy x) -instance StaticByteSized Word24BE where-  staticByteSize _ = 3+instance StaticByteSized le => StaticByteSized (ViaEndianPair le be) where+  staticByteSize _ = staticByteSize (Proxy :: Proxy le) -instance StaticByteSized Int24BE where-  staticByteSize _ = 3+deriving via (ViaEndianPair Word16LE Word16BE) instance StaticByteSized Word16BE -instance StaticByteSized Word32BE where-  staticByteSize _ = 4+deriving via (ViaEndianPair Int16LE Int16BE) instance StaticByteSized Int16BE -instance StaticByteSized Int32BE where-  staticByteSize _ = 4+deriving via (ViaEndianPair Word24LE Word24BE) instance StaticByteSized Word24BE -instance StaticByteSized FloatBE where-  staticByteSize _ = 4+deriving via (ViaEndianPair Int24LE Int24BE) instance StaticByteSized Int24BE +deriving via (ViaEndianPair Word32LE Word32BE) instance StaticByteSized Word32BE++deriving via (ViaEndianPair Int32LE Int32BE) instance StaticByteSized Int32BE++deriving via (ViaEndianPair Word64LE Word64BE) instance StaticByteSized Word64BE++deriving via (ViaEndianPair Int64LE Int64BE) instance StaticByteSized Int64BE++deriving via (ViaEndianPair FloatLE FloatBE) instance StaticByteSized FloatBE++deriving via (ViaEndianPair DoubleLE DoubleBE) instance StaticByteSized DoubleBE++-- Via+ newtype ViaStaticByteSized a = ViaStaticByteSized {unViaStaticByteSized :: a}  instance StaticByteSized a => ByteSized (ViaStaticByteSized a) where@@ -226,4 +336,7 @@ byteSizeFoldable = getSum . foldMap' (Sum . byteSize)  staticByteSizeFoldable :: (Foldable f, StaticByteSized a) => f a -> ByteCount-staticByteSizeFoldable fa = staticByteSize (proxyForF fa) * fromIntegral (length fa)+staticByteSizeFoldable fa = staticByteSize (proxyForF fa) * coerce (length fa)++byteSizeViaStatic :: StaticByteSized a => a -> ByteCount+byteSizeViaStatic = staticByteSize . proxyFor

@@ -2,27 +2,46 @@  import Dahdit   ( Binary (..)-  , BoolByte (BoolByte)-  , ByteCount+  , BinaryTarget (..)+  , BoolByte (..)+  , ByteCount (..)   , ByteSized (..)+  , ByteString+  , DoubleBE (..)+  , DoubleLE (..)   , FloatBE (..)   , FloatLE (..)   , Generic   , Get+  , GetError (..)+  , Int16BE   , Int16LE+  , Int24BE+  , Int24LE+  , Int32BE   , Int32LE-  , Int8+  , Int64BE+  , Int64LE+  , LiftedPrimArray (..)   , Proxy (..)   , Put   , ShortByteString   , StaticByteSized (..)+  , StaticBytes (..)   , ViaGeneric (..)   , ViaStaticGeneric (..)+  , Word16BE   , Word16LE+  , Word24BE+  , Word24LE+  , Word32BE   , Word32LE-  , Word8+  , Word64BE+  , Word64LE   , getByteArray   , getByteString+  , getDoubleBE+  , getDoubleLE   , getExact   , getFloatBE   , getFloatLE@@ -32,6 +51,8 @@   , getInt24LE   , getInt32BE   , getInt32LE+  , getInt64BE+  , getInt64LE   , getInt8   , getLiftedPrimArray   , getLookAhead@@ -40,6 +61,7 @@   , getSkip   , getStaticArray   , getStaticSeq+  , getTarget   , getWithin   , getWord16BE   , getWord16LE@@ -47,10 +69,15 @@   , getWord24LE   , getWord32BE   , getWord32LE+  , getWord64BE+  , getWord64LE   , getWord8+  , lengthLiftedPrimArray   , liftedPrimArrayFromList   , putByteArray   , putByteString+  , putDoubleBE+  , putDoubleLE   , putFloatBE   , putFloatLE   , putInt16BE@@ -59,6 +86,8 @@   , putInt24LE   , putInt32BE   , putInt32LE+  , putInt64BE+  , putInt64LE   , putInt8   , putLiftedPrimArray   , putSeq@@ -70,19 +99,44 @@   , putWord24LE   , putWord32BE   , putWord32LE+  , putWord64BE+  , putWord64LE   , putWord8   , runCount-  , runGet-  , runPut+  , sizeofLiftedPrimArray   )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC 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.PrimArray (primArrayFromList)+import Data.Proxy (asProxyTypeOf) import qualified Data.Sequence as Seq-import GHC.Float (castWord32ToFloat)+import Data.ShortWord (Int24, Word24)+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as VS+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Float (castWord32ToFloat, castWord64ToDouble) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) +class BinaryTarget z => CaseTarget z where+  initSource :: [Word8] -> z+  consumeSink :: z -> [Word8]++instance CaseTarget ShortByteString where+  initSource = BSS.pack+  consumeSink = BSS.unpack++instance CaseTarget ByteString where+  initSource = BS.pack+  consumeSink = BS.unpack++instance CaseTarget (Vector Word8) where+  initSource = VS.fromList+  consumeSink = VS.toList+ data DynFoo = DynFoo !Word8 !Word16LE   deriving stock (Eq, Show, Generic)   deriving (ByteSized, Binary) via (ViaGeneric DynFoo)@@ -91,145 +145,276 @@   deriving stock (Eq, Show, Generic)   deriving (ByteSized, StaticByteSized, Binary) via (ViaStaticGeneric StaFoo) -runGetCase :: (Show a, Eq a) => Get a -> Maybe (ByteCount, ByteCount, a) -> [Word8] -> IO ()-runGetCase getter mayRes bsl = do-  let bs = BSS.pack bsl-      (result, actBc) = runGet getter bs+data TagFoo = TagFooOne !Word8 | TagFooTwo !Word16LE+  deriving stock (Eq, Show, Generic)+  deriving (ByteSized, Binary) via (ViaGeneric TagFoo)++type StaBytes = StaticBytes 2++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+  let src = initSource buf `asProxyTypeOf` p+      totLen = coerce (length buf)+      (result, actOff) = getTarget getter src   case (result, mayRes) of     (Left _, Nothing) -> pure ()     (Left err, Just (_, _, expecVal)) -> fail ("Got error <" ++ show err ++ ">, expected value <" ++ show expecVal ++ ">")     (Right actVal, Nothing) -> fail ("Got value <" ++ show actVal ++ ">, expected error")-    (Right actVal, Just (expecBc, expecLeft, expecVal)) -> do+    (Right actVal, Just (expecOff, expecLeft, expecVal)) -> do       actVal @?= expecVal-      actBc @?= expecBc-      BSS.length bs - fromIntegral actBc @?= fromIntegral expecLeft+      actOff @?= expecOff+      totLen - actOff @?= expecLeft -runPutCase :: Put -> [Word8] -> IO ()-runPutCase putter expecList = do-  let expecBc = fromIntegral (length expecList)-      expecBs = BSS.pack expecList+runPutCase :: CaseTarget z => Proxy z -> Put -> [Word8] -> IO ()+runPutCase p putter expecList = do+  let expecBc = coerce (length expecList)+      expecBs = expecList       estBc = runCount putter   estBc @?= expecBc-  let actBs = runPut putter-      actBc = byteSize actBs+  let actSink = putTargetUnsafe putter estBc `asProxyTypeOf` p+      actBs = consumeSink actSink+      actBc = coerce (length actBs)   actBs @?= expecBs   actBc @?= expecBc -testDahditByteSize :: TestTree-testDahditByteSize =+testByteSize :: TestTree+testByteSize =   testGroup     "byteSize"-    [ testCase "Word8" (byteSize @Word8 0x5D @?= 1)-    , testCase "Int8" (byteSize @Int8 0x5D @?= 1)-    , testCase "Word16LE" (byteSize @Word16LE 0x5DEC @?= 2)-    , testCase "Int16LE" (byteSize @Int16LE 0x5DEC @?= 2)-    , testCase "Word32LE" (byteSize @Word32LE 0x5DEC6EFD @?= 4)-    , testCase "Int32LE" (byteSize @Int32LE 0x5DEC6EFD @?= 4)-    , testCase "FloatLE" (byteSize (FloatLE (castWord32ToFloat 0x5DEC6EFD)) @?= 4)+    [ testCase "Word8" (byteSize @Word8 0 @?= 1)+    , testCase "Int8" (byteSize @Int8 0 @?= 1)+    , testCase "Word16" (byteSize @Word16 0 @?= 2)+    , testCase "Int16" (byteSize @Int16 0 @?= 2)+    , testCase "Word24" (byteSize @Word24 0 @?= 3)+    , testCase "Int24" (byteSize @Int24 0 @?= 3)+    , testCase "Word32" (byteSize @Word32 0 @?= 4)+    , testCase "Int32" (byteSize @Int32 0 @?= 4)+    , testCase "Word64" (byteSize @Word64 0 @?= 8)+    , testCase "Int64" (byteSize @Int64 0 @?= 8)+    , testCase "Float" (byteSize @Float 0 @?= 4)+    , testCase "Double" (byteSize @Double 0 @?= 8)+    , testCase "()" (byteSize @() () @?= 0)+    , testCase "Bool" (byteSize @Bool False @?= 1)+    , testCase "Char" (byteSize @Char 'a' @?= 1)+    , testCase "Int" (byteSize @Int 0 @?= 8)+    , testCase "Word16LE" (byteSize @Word16LE 0 @?= 2)+    , testCase "Int16LE" (byteSize @Int16LE 0 @?= 2)+    , testCase "Word24LE" (byteSize @Word24LE 0 @?= 3)+    , testCase "Int24LE" (byteSize @Int24LE 0 @?= 3)+    , testCase "Word32LE" (byteSize @Word32LE 0 @?= 4)+    , testCase "Int32LE" (byteSize @Int32LE 0 @?= 4)+    , testCase "Word64LE" (byteSize @Word64LE 0 @?= 8)+    , testCase "Int64LE" (byteSize @Int64LE 0 @?= 8)+    , testCase "FloatLE" (byteSize (FloatLE (castWord32ToFloat 0)) @?= 4)+    , testCase "DoubleLE" (byteSize (DoubleLE (castWord64ToDouble 0)) @?= 8)+    , testCase "Word16BE" (byteSize @Word16BE 0 @?= 2)+    , testCase "Int16BE" (byteSize @Int16BE 0 @?= 2)+    , testCase "Word24BE" (byteSize @Word24BE 0 @?= 3)+    , testCase "Int24BE" (byteSize @Int24BE 0 @?= 3)+    , testCase "Word32BE" (byteSize @Word32BE 0 @?= 4)+    , testCase "Int32BE" (byteSize @Int32BE 0 @?= 4)+    , testCase "Word64BE" (byteSize @Word64BE 0 @?= 8)+    , testCase "Int64BE" (byteSize @Int64BE 0 @?= 8)+    , testCase "FloatBE" (byteSize (FloatBE (castWord32ToFloat 0)) @?= 4)+    , testCase "DoubleBE" (byteSize (DoubleBE (castWord64ToDouble 0)) @?= 8)     , testCase "ShortByteString" (byteSize @ShortByteString (BSS.pack [0xEC, 0x5D]) @?= 2)     , testCase "DynFoo" (byteSize (DynFoo 0xBB 0x5DEC) @?= 3)     , testCase "StaFoo" (byteSize (StaFoo 0xBB 0x5DEC) @?= 3)+    , testCase "StaBytes" (byteSize (mkStaBytes "hi") @?= 2)+    , testCase "StaBytes (less)" (byteSize (mkStaBytes "h") @?= 2)+    , testCase "StaBytes (more)" (byteSize (mkStaBytes "hi!") @?= 2)+    , testCase "TagFoo (one)" (byteSize (TagFooOne 7) @?= 2)+    , testCase "TagFoo (two)" (byteSize (TagFooTwo 7) @?= 3)     ] -testDahditStaticByteSize :: TestTree-testDahditStaticByteSize =+testStaticByteSize :: TestTree+testStaticByteSize =   testGroup     "staticByteSize"     [ testCase "Word8" (staticByteSize @Word8 Proxy @?= 1)     , testCase "Int8" (staticByteSize @Int8 Proxy @?= 1)+    , testCase "Word16" (staticByteSize @Word16 Proxy @?= 2)+    , testCase "Int16" (staticByteSize @Int16 Proxy @?= 2)+    , testCase "Word24" (staticByteSize @Word24 Proxy @?= 3)+    , testCase "Int24" (staticByteSize @Int24 Proxy @?= 3)+    , testCase "Word32" (staticByteSize @Word32 Proxy @?= 4)+    , testCase "Int32" (staticByteSize @Int32 Proxy @?= 4)+    , testCase "Word64" (staticByteSize @Word64 Proxy @?= 8)+    , testCase "Int64" (staticByteSize @Int64 Proxy @?= 8)+    , testCase "Float" (staticByteSize @Float Proxy @?= 4)+    , testCase "Double" (staticByteSize @Double Proxy @?= 8)+    , testCase "()" (staticByteSize @() Proxy @?= 0)+    , testCase "Bool" (staticByteSize @Bool Proxy @?= 1)+    , testCase "Char" (staticByteSize @Char Proxy @?= 1)+    , testCase "Int" (staticByteSize @Int Proxy @?= 8)     , testCase "Word16LE" (staticByteSize @Word16LE Proxy @?= 2)     , testCase "Int16LE" (staticByteSize @Int16LE Proxy @?= 2)+    , testCase "Word24LE" (staticByteSize @Word24LE Proxy @?= 3)+    , testCase "Int24LE" (staticByteSize @Int24LE Proxy @?= 3)     , testCase "Word32LE" (staticByteSize @Word32LE Proxy @?= 4)     , testCase "Int32LE" (staticByteSize @Int32LE Proxy @?= 4)+    , testCase "Word64LE" (staticByteSize @Word64LE Proxy @?= 8)+    , testCase "Int64LE" (staticByteSize @Int64LE Proxy @?= 8)     , testCase "FloatLE" (staticByteSize @FloatLE Proxy @?= 4)+    , testCase "DoubleLE" (staticByteSize @DoubleLE Proxy @?= 8)+    , testCase "Word16BE" (staticByteSize @Word16BE Proxy @?= 2)+    , testCase "Int16BE" (staticByteSize @Int16BE Proxy @?= 2)+    , testCase "Word24BE" (staticByteSize @Word24BE Proxy @?= 3)+    , testCase "Int24BE" (staticByteSize @Int24BE Proxy @?= 3)+    , testCase "Word32BE" (staticByteSize @Word32BE Proxy @?= 4)+    , testCase "Int32BE" (staticByteSize @Int32BE Proxy @?= 4)+    , testCase "Word64BE" (staticByteSize @Word64BE Proxy @?= 8)+    , testCase "Int64BE" (staticByteSize @Int64BE Proxy @?= 8)+    , testCase "FloatBE" (staticByteSize @FloatBE Proxy @?= 4)+    , testCase "DoubleBE" (staticByteSize @DoubleBE Proxy @?= 8)     , testCase "StaFoo" (staticByteSize @StaFoo Proxy @?= 3)     , testCase "BoolByte" (staticByteSize @BoolByte Proxy @?= 1)+    , testCase "StaBytes" (staticByteSize @StaBytes Proxy @?= 2)     ] -testDahditGet :: TestTree-testDahditGet =+testGet :: CaseTarget z => String -> Proxy z -> TestTree+testGet n p =   testGroup-    "get"-    [ testCase "Word8 zero" (runGetCase getWord8 Nothing [])-    , testCase "Word8 one" (runGetCase getWord8 (Just (1, 0, 0x5D)) [0x5D])-    , testCase "Word8 two" (runGetCase getWord8 (Just (1, 1, 0x5D)) [0x5D, 0xBB])-    , testCase "Int8" (runGetCase getInt8 (Just (1, 0, 0x5D)) [0x5D])-    , testCase "Word16LE zero" (runGetCase getWord16LE Nothing [])-    , testCase "Word16LE one" (runGetCase getWord16LE Nothing [0x5D])-    , testCase "Word16LE two" (runGetCase getWord16LE (Just (2, 0, 0x5DEC)) [0xEC, 0x5D])-    , testCase "Word16LE three" (runGetCase getWord16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "Int16LE" (runGetCase getInt16LE (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "Word16BE" (runGetCase getWord16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB])-    , testCase "Int16BE" (runGetCase getInt16BE (Just (2, 1, 0x5DEC)) [0x5D, 0xEC, 0xBB])-    , testCase "Word24LE" (runGetCase getWord24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int24LE" (runGetCase getInt24LE (Just (3, 1, 0xEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word24BE" (runGetCase getWord24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D])-    , testCase "Int24BE" (runGetCase getInt24BE (Just (3, 1, 0xEC6EFD)) [0xEC, 0x6E, 0xFD, 0x5D])-    , testCase "Word32LE" (runGetCase getWord32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int32LE" (runGetCase getInt32LE (Just (4, 0, 0x5DEC6EFD)) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word32BE" (runGetCase getWord32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Int32BE" (runGetCase getInt32BE (Just (4, 0, 0x5DEC6EFD)) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "FloatLE" (runGetCase getFloatLE (Just (4, 0, FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "FloatBE" (runGetCase getFloatBE (Just (4, 0, FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "ShortByteString" (runGetCase (getByteString 2) (Just (2, 1, BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D, 0xBB])-    , testCase "Two Word8" (runGetCase ((,) <$> getWord8 <*> getWord8) (Just (2, 0, (0x5D, 0xBB))) [0x5D, 0xBB])-    , testCase "Two Word16LE" (runGetCase ((,) <$> getWord16LE <*> getWord16LE) (Just (4, 0, (0x5DEC, 0x4020))) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "Seq" (runGetCase (getSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticSeq" (runGetCase (getStaticSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticArray" (runGetCase (getStaticArray @Word16LE 2) (Just (4, 0, primArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "DynFoo" (runGetCase (get @DynFoo) (Just (3, 0, DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "StaFoo" (runGetCase (get @StaFoo) (Just (3, 0, StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "getRemainingSize" (runGetCase getRemainingSize (Just (0, 3, 3)) [0xBB, 0xEC, 0x5D])-    , testCase "getSkip" (runGetCase (getSkip 2) (Just (2, 1, ())) [0xBB, 0xEC, 0x5D])-    , testCase "getLookAhead" (runGetCase (getLookAhead getWord16LE) (Just (0, 3, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getExact eq" (runGetCase (getExact 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getExact lt" (runGetCase (getExact 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getExact gt" (runGetCase (getExact 3 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getWithin eq" (runGetCase (getWithin 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "getWithin lt" (runGetCase (getWithin 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB])-    , testCase "getWithin gt" (runGetCase (getWithin 3 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB])-    , testCase "BoolByte True" (runGetCase (get @BoolByte) (Just (1, 0, BoolByte True)) [0x01])-    , testCase "BoolByte False" (runGetCase (get @BoolByte) (Just (1, 0, BoolByte False)) [0x00])-    , testCase "getByteArray" (runGetCase (getByteArray 3) (Just (3, 1, byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "getLiftedPrimArray" (runGetCase (getLiftedPrimArray (Proxy :: Proxy Word16LE) 3) (Just (6, 1, liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00, 0x5D])+    ("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])     ] -testDahditPut :: TestTree-testDahditPut =+testPut :: CaseTarget z => String -> Proxy z -> TestTree+testPut n p =   testGroup-    "put"-    [ testCase "Word8" (runPutCase (putWord8 0x5D) [0x5D])-    , testCase "Int8" (runPutCase (putInt8 0x5D) [0x5D])-    , testCase "Word16LE" (runPutCase (putWord16LE 0x5DEC) [0xEC, 0x5D])-    , testCase "Int16LE" (runPutCase (putInt16LE 0x5DEC) [0xEC, 0x5D])-    , testCase "Word16BE" (runPutCase (putWord16BE 0x5DEC) [0x5D, 0xEC])-    , testCase "Int16BE" (runPutCase (putInt16BE 0x5DEC) [0x5D, 0xEC])-    , testCase "Word24LE" (runPutCase (putWord24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC])-    , testCase "Int24LE" (runPutCase (putInt24LE 0xEC6EFD) [0xFD, 0x6E, 0xEC])-    , testCase "Word24BE" (runPutCase (putWord24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD])-    , testCase "Int24BE" (runPutCase (putInt24BE 0xEC6EFD) [0xEC, 0x6E, 0xFD])-    , testCase "Word32LE" (runPutCase (putWord32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Int32LE" (runPutCase (putInt32LE 0x5DEC6EFD) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "Word32BE" (runPutCase (putWord32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "Int32BE" (runPutCase (putInt32BE 0x5DEC6EFD) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "FloatLE" (runPutCase (putFloatLE (FloatLE (castWord32ToFloat 0x5DEC6EFD))) [0xFD, 0x6E, 0xEC, 0x5D])-    , testCase "FloatBE" (runPutCase (putFloatBE (FloatBE (castWord32ToFloat 0x5DEC6EFD))) [0x5D, 0xEC, 0x6E, 0xFD])-    , testCase "ShortByteString" (runPutCase (putByteString (BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D])-    , testCase "Two Word8" (runPutCase (putWord8 0x5D *> putWord8 0xBB) [0x5D, 0xBB])-    , testCase "Two Word16LE" (runPutCase (putWord16LE 0x5DEC *> putWord16LE 0x4020) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "Seq" (runPutCase (putSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticSeq" (runPutCase (putStaticSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "StaticArray" (runPutCase (putStaticArray @Word16LE (primArrayFromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40])-    , testCase "DynFoo" (runPutCase (put (DynFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "StaFoo" (runPutCase (put (StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D])-    , testCase "BoolByte True" (runPutCase (put (BoolByte True)) [0x01])-    , testCase "BoolByte False" (runPutCase (put (BoolByte False)) [0x00])-    , testCase "putByteArray" (runPutCase (putByteArray (byteArrayFromList @Word8 [0xFD, 0x6E, 0xEC])) [0xFD, 0x6E, 0xEC])-    , testCase "putLiftedPrimArray" (runPutCase (putLiftedPrimArray (liftedPrimArrayFromList @Word16LE [0xFD, 0x6E, 0xEC])) [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00])+    ("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])     ] +testLiftedPrimArray :: TestTree+testLiftedPrimArray = testCase "liftedPrimArray" $ do+  let arr = LiftedPrimArray (byteArrayFromList @Word8 [0xFD, 0x00, 0x6E, 0x00, 0xEC, 0x00]) :: LiftedPrimArray Word16LE+  liftedPrimArrayFromList [0xFD, 0x6E, 0xEC] @?= arr+  sizeofLiftedPrimArray arr @?= 6+  lengthLiftedPrimArray arr @?= 3++testGetWithOffset :: CaseTarget z => String -> Proxy z -> TestTree+testGetWithOffset n p = testCase ("get with offset (" ++ n ++ ")") $ do+  let buf = [0x12, 0x34, 0x56, 0x78]+      src = initSource buf `asProxyTypeOf` p+      (ez1, c1) = getTargetOffset 0 getWord8 src+  ez1 @?= Right 0x12+  c1 @?= 1+  let (ez2, c2) = getTargetOffset 1 getWord16LE src+  ez2 @?= Right 0x5634+  c2 @?= 3+  let (ez3, c3) = getTargetOffset 3 getWord16LE src+  ez3 @?= Left (GetErrorParseNeed "Word16LE" 1 2)+  c3 @?= 3+ testDahdit :: TestTree-testDahdit = testGroup "Dahdit" [testDahditByteSize, testDahditStaticByteSize, testDahditGet, testDahditPut]+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))+    ]  main :: IO () main = defaultMain testDahdit