dahdit 0.1.2 → 0.1.3
raw patch · 17 files changed
+677/−291 lines, 17 filesdep ~bytestringsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bytestring
API changes (from Hackage documentation)
+ Dahdit.Codec: ViaBinary :: a -> ViaBinary a
+ Dahdit.Codec: ViaCodec :: a -> ViaCodec a
+ Dahdit.Codec: [unViaBinary] :: ViaBinary a -> a
+ Dahdit.Codec: [unViaCodec] :: ViaCodec a -> a
+ Dahdit.Codec: binary :: Binary a => Codec a
+ Dahdit.Codec: bindPair :: Codec a -> (a -> Codec b) -> Codec (a, b)
+ Dahdit.Codec: bindTag :: (b -> a) -> Codec a -> (a -> Codec b) -> Codec b
+ Dahdit.Codec: build :: Get a -> (a -> Put) -> Codec a
+ Dahdit.Codec: class HasCodec a
+ Dahdit.Codec: codec :: HasCodec a => Codec a
+ Dahdit.Codec: instance (Dahdit.Sizes.ByteSized a, Dahdit.Codec.HasCodec a) => Dahdit.Binary.Binary (Dahdit.Codec.ViaCodec a)
+ Dahdit.Codec: instance (GHC.TypeNats.KnownNat n, Dahdit.Binary.Binary a, Dahdit.Sizes.StaticByteSized a, Data.Default.Class.Default a) => Dahdit.Codec.HasCodec (Dahdit.Fancy.StaticSeq n a)
+ Dahdit.Codec: instance (GHC.TypeNats.KnownNat n, Data.Primitive.Types.Prim a, Dahdit.Sizes.StaticByteSized a, Data.Default.Class.Default a) => Dahdit.Codec.HasCodec (Dahdit.Fancy.StaticArray n a)
+ Dahdit.Codec: instance Dahdit.Binary.Binary a => Dahdit.Codec.HasCodec (Dahdit.Codec.ViaBinary a)
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Fancy.BoolByte
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Fancy.TermBytes
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.FloatBE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.FloatLE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int16BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int16LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int24BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int24LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int32BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Int32LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word16BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word16LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word24BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word24LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word32BE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec Dahdit.Nums.Word32LE
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec GHC.Int.Int8
+ Dahdit.Codec: instance Dahdit.Codec.HasCodec GHC.Word.Word8
+ Dahdit.Codec: instance Dahdit.Sizes.ByteSized a => Dahdit.Sizes.ByteSized (Dahdit.Codec.ViaCodec a)
+ Dahdit.Codec: instance GHC.Base.Applicative (Dahdit.Codec.Codec' x)
+ Dahdit.Codec: instance GHC.Base.Functor (Dahdit.Codec.Codec' x)
+ Dahdit.Codec: instance GHC.TypeLits.KnownSymbol s => Dahdit.Codec.HasCodec (Dahdit.Fancy.ExactBytes s)
+ Dahdit.Codec: newtype ViaBinary a
+ Dahdit.Codec: newtype ViaCodec a
+ Dahdit.Codec: parse :: Codec a -> Get a
+ Dahdit.Codec: produce :: Codec a -> a -> Put
+ Dahdit.Codec: type Codec a = Codec' a a
Files
- Setup.hs +0/−2
- dahdit.cabal +6/−3
- src/Dahdit.hs +2/−1
- src/Dahdit/Binary.hs +52/−7
- src/Dahdit/BinaryRep.hs +7/−6
- src/Dahdit/Codec.hs +130/−0
- src/Dahdit/Fancy.hs +36/−26
- src/Dahdit/Free.hs +26/−11
- src/Dahdit/Funs.hs +48/−17
- src/Dahdit/Generic.hs +5/−4
- src/Dahdit/Internal.hs +12/−10
- src/Dahdit/LiftedPrim.hs +24/−11
- src/Dahdit/Nums.hs +34/−23
- src/Dahdit/Proxy.hs +2/−1
- src/Dahdit/Run.hs +88/−52
- src/Dahdit/Sizes.hs +24/−9
- test/Main.hs +181/−108
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
dahdit.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: dahdit-version: 0.1.2+version: 0.1.3 synopsis: Binary parsing and serialization with integrated size description: Please see the README on GitHub at <https://github.com/ejconlon/dahdit#readme> category: Data@@ -17,6 +17,8 @@ license: BSD3 license-file: LICENSE build-type: Simple+tested-with:+ GHC == 9.2.7 extra-source-files: README.md @@ -29,6 +31,7 @@ Dahdit Dahdit.Binary Dahdit.BinaryRep+ Dahdit.Codec Dahdit.Fancy Dahdit.Free Dahdit.Funs@@ -71,7 +74,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -fwrite-ide-info -hiedir=.hie build-depends: base >=4.12 && <5- , bytestring >=0.10 && <0.12+ , bytestring ==0.11.* , containers ==0.6.* , data-default ==0.7.* , data-sword ==0.2.*@@ -116,7 +119,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.12 && <5- , bytestring >=0.10 && <0.12+ , bytestring ==0.11.* , containers ==0.6.* , dahdit , data-default ==0.7.*
src/Dahdit.hs view
@@ -20,7 +20,8 @@ , module Dahdit.Proxy , module Dahdit.Run , module Dahdit.Sizes- ) where+ )+where import Dahdit.Binary import Dahdit.BinaryRep
src/Dahdit/Binary.hs view
@@ -1,15 +1,60 @@ module Dahdit.Binary ( Binary (..) , byteSizeViaPut- ) where+ )+where import Dahdit.Free (Get, Put)-import Dahdit.Funs (getFloatBE, getFloatLE, getInt16BE, getInt16LE, getInt24BE, getInt24LE, getInt32BE, getInt32LE,- getInt8, getWord16BE, getWord16LE, getWord24BE, getWord24LE, getWord32BE, getWord32LE, getWord8,- putFloatBE, putFloatLE, putInt16BE, putInt16LE, putInt24BE, putInt24LE, putInt32BE, putInt32LE,- putInt8, putWord16BE, putWord16LE, putWord24BE, putWord24LE, putWord32BE, putWord32LE, putWord8)-import Dahdit.Nums (FloatBE (..), FloatLE, Int16BE (..), Int16LE, Int24BE (..), Int24LE, Int32BE (..), Int32LE,- Word16BE (..), Word16LE, Word24BE (..), Word24LE, Word32BE (..), Word32LE)+import Dahdit.Funs+ ( getFloatBE+ , getFloatLE+ , getInt16BE+ , getInt16LE+ , getInt24BE+ , getInt24LE+ , getInt32BE+ , getInt32LE+ , getInt8+ , getWord16BE+ , getWord16LE+ , getWord24BE+ , getWord24LE+ , getWord32BE+ , getWord32LE+ , getWord8+ , putFloatBE+ , putFloatLE+ , putInt16BE+ , putInt16LE+ , putInt24BE+ , putInt24LE+ , putInt32BE+ , putInt32LE+ , putInt8+ , putWord16BE+ , putWord16LE+ , putWord24BE+ , putWord24LE+ , putWord32BE+ , putWord32LE+ , putWord8+ )+import Dahdit.Nums+ ( FloatBE (..)+ , FloatLE+ , Int16BE (..)+ , Int16LE+ , Int24BE (..)+ , Int24LE+ , Int32BE (..)+ , Int32LE+ , Word16BE (..)+ , Word16LE+ , Word24BE (..)+ , Word24LE+ , Word32BE (..)+ , Word32LE+ ) import Dahdit.Run (runCount) import Dahdit.Sizes (ByteCount, ByteSized) import Data.Int (Int8)
src/Dahdit/BinaryRep.hs view
@@ -4,7 +4,8 @@ ( BinaryRep (..) , ViaBoundedEnum (..) , ViaBinaryRep (..)- ) where+ )+where import Dahdit.Binary (Binary (..)) import Dahdit.Sizes (ByteSized (..), StaticByteSized (..))@@ -14,17 +15,17 @@ fromBinaryRep :: x -> Either String a toBinaryRep :: a -> x -newtype ViaBoundedEnum x a = ViaBoundedEnum { unViaBoundedEnum :: a }+newtype ViaBoundedEnum x a = ViaBoundedEnum {unViaBoundedEnum :: a} instance (Binary x, Integral x, Bounded a, Enum a) => BinaryRep x (ViaBoundedEnum x a) where fromBinaryRep x = let i = fromIntegral x- in if i < fromEnum (minBound :: a) || i > fromEnum (maxBound :: a)- then Left ("Invalid enum value: " ++ show i)- else Right (ViaBoundedEnum (toEnum i))+ in if i < fromEnum (minBound :: a) || i > fromEnum (maxBound :: a)+ then Left ("Invalid enum value: " ++ show i)+ else Right (ViaBoundedEnum (toEnum i)) toBinaryRep = fromIntegral . fromEnum . unViaBoundedEnum -newtype ViaBinaryRep a = ViaBinaryRep { unViaBinaryRep :: a }+newtype ViaBinaryRep a = ViaBinaryRep {unViaBinaryRep :: a} instance BinaryRep x a => ByteSized (ViaBinaryRep a) where byteSize = byteSize . toBinaryRep . unViaBinaryRep
+ src/Dahdit/Codec.hs view
@@ -0,0 +1,130 @@+-- Experimental - bidirectional codecs+-- See https://hackage.haskell.org/package/codec+-- And https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html+module Dahdit.Codec+ ( Codec+ , build+ , binary+ , parse+ , produce+ , bindPair+ , bindTag+ , HasCodec (..)+ , ViaBinary (..)+ , ViaCodec (..)+ )+where++import Dahdit.Binary (Binary (..))+import Dahdit.Fancy (BoolByte, ExactBytes, StaticArray, StaticSeq, TermBytes)+import Dahdit.Free (Get, Put)+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)++data Codec' x a = Codec'+ { parse' :: Get a+ , produce' :: x -> Put+ }++instance Functor (Codec' x) where+ fmap f c = c {parse' = fmap f (parse' c)}++instance Applicative (Codec' x) where+ pure a = Codec' (pure a) (const (pure ()))++ f <*> a =+ Codec'+ { parse' = parse' f <*> parse' a+ , produce' = \x -> produce' f x *> produce' a x+ }++type Codec a = Codec' a a++build :: Get a -> (a -> Put) -> Codec a+build = Codec'++binary :: Binary a => Codec a+binary = build get put++parse :: Codec a -> Get a+parse = parse'++produce :: Codec a -> a -> Put+produce = produce'++bindPair :: Codec a -> (a -> Codec b) -> Codec (a, b)+bindPair c f =+ Codec'+ (parse c >>= \a -> fmap (a,) (parse (f a)))+ (\(a, b) -> produce c a *> produce (f a) b)++bindTag :: (b -> a) -> Codec a -> (a -> Codec b) -> Codec b+bindTag t c f =+ Codec'+ (parse c >>= parse . f)+ (\b -> let a = t b in produce c a *> produce (f a) b)++class HasCodec a where+ codec :: Codec a++newtype ViaBinary a = ViaBinary {unViaBinary :: a}++instance Binary a => HasCodec (ViaBinary a) where+ codec = coerce (binary @a)++deriving via (ViaBinary Word8) instance HasCodec Word8++deriving via (ViaBinary Int8) instance HasCodec Int8++deriving via (ViaBinary Word16LE) instance HasCodec Word16LE++deriving via (ViaBinary Int16LE) instance HasCodec Int16LE++deriving via (ViaBinary Word24LE) instance HasCodec Word24LE++deriving via (ViaBinary Int24LE) instance HasCodec Int24LE++deriving via (ViaBinary Word32LE) instance HasCodec Word32LE++deriving via (ViaBinary Int32LE) instance HasCodec Int32LE++deriving via (ViaBinary FloatLE) instance HasCodec FloatLE++deriving via (ViaBinary Word16BE) instance HasCodec Word16BE++deriving via (ViaBinary Int16BE) instance HasCodec Int16BE++deriving via (ViaBinary Word24BE) instance HasCodec Word24BE++deriving via (ViaBinary Int24BE) instance HasCodec Int24BE++deriving via (ViaBinary Word32BE) instance HasCodec Word32BE++deriving via (ViaBinary Int32BE) instance HasCodec Int32BE++deriving via (ViaBinary FloatBE) instance HasCodec FloatBE++deriving via (ViaBinary TermBytes) instance HasCodec TermBytes++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 BoolByte) instance HasCodec BoolByte++deriving via (ViaBinary (ExactBytes s)) instance KnownSymbol s => HasCodec (ExactBytes s)++newtype ViaCodec a = ViaCodec {unViaCodec :: a}++instance ByteSized a => ByteSized (ViaCodec a) where+ byteSize = byteSize . unViaCodec++instance (ByteSized a, HasCodec a) => Binary (ViaCodec a) where+ get = coerce (parse (codec @a))+ put = coerce (produce (codec @a))
src/Dahdit/Fancy.hs view
@@ -7,16 +7,26 @@ , StaticArray (..) , BoolByte (..) , ExactBytes (..)- ) where+ )+where import Control.Monad (unless) import Dahdit.Binary (Binary (..)) import Dahdit.Free (Get)-import Dahdit.Funs (getByteString, getExpect, getStaticArray, getStaticSeq, getWord8, putByteString, putFixedString,- putWord8, unsafePutStaticArrayN, unsafePutStaticSeqN)+import Dahdit.Funs+ ( getByteString+ , getExpect+ , getStaticArray+ , getStaticSeq+ , getWord8+ , putByteString+ , putFixedString+ , putWord8+ , unsafePutStaticArrayN+ , unsafePutStaticSeqN+ ) import Dahdit.Proxy (proxyForNatF) import Dahdit.Sizes (ByteSized (..), StaticByteSized (..), ViaStaticByteSized (..))-import qualified Data.ByteString as BS import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Short as BSS import Data.ByteString.Short.Internal (ShortByteString (..))@@ -32,14 +42,15 @@ import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) getUntilNull :: Get (Int, [Word8])-getUntilNull = go 0 [] where+getUntilNull = go 0 []+ where go !i !racc = do w <- getWord8 if w == 0 then let !acc = reverse racc- in pure (i, acc)- else go (i + 1) (w:racc)+ in pure (i, acc)+ else go (i + 1) (w : racc) mkSBS :: Int -> [Word8] -> ShortByteString mkSBS n bs = let !(ByteArray ba) = byteArrayFromListN n bs in SBS ba@@ -47,7 +58,7 @@ -- | Bytes terminated with null byte. -- NOTE: Terminated with TWO null bytes if the string is even length -- to align to Word16 boundaries, as required for RIFF format, for example.-newtype TermBytes = TermBytes { unTermBytes :: ShortByteString }+newtype TermBytes = TermBytes {unTermBytes :: ShortByteString} deriving stock (Show) deriving newtype (Eq, Ord, IsString) @@ -57,7 +68,7 @@ instance ByteSized TermBytes where byteSize (TermBytes sbs) = let !bc = byteSize sbs + 1- in if even bc then bc else bc + 1+ in if even bc then bc else bc + 1 instance Binary TermBytes where get = do@@ -74,24 +85,23 @@ unless (odd (BSS.length sbs)) (putWord8 0) -- | A fixed-length bytestring (truncated or zero-padded on put if length does not match).-newtype StaticBytes (n :: Nat) = StaticBytes { unStaticBytes :: ShortByteString }+newtype StaticBytes (n :: Nat) = StaticBytes {unStaticBytes :: ShortByteString} deriving stock (Show) deriving newtype (IsString) deriving (ByteSized) via (ViaStaticByteSized (StaticBytes n)) mkStaticBytes :: KnownNat n => Proxy n -> ShortByteString -> StaticBytes n mkStaticBytes prox sbs =- -- TODO replace with the Short versions when the lib is updated to 0.11 let n = fromInteger (natVal prox)- in if BSS.length sbs == n- then StaticBytes sbs- else- let bs = BSS.fromShort sbs- x1 = BS.take n bs- l = BS.length x1- in StaticBytes $ BSS.toShort $ if l == n- then x1- else x1 <> BS.replicate (n - l) 0+ in if BSS.length sbs == n+ then StaticBytes sbs+ else+ let x1 = BSS.take n sbs+ l = BSS.length x1+ in StaticBytes $+ if l == n+ then x1+ else x1 <> BSS.replicate (n - l) 0 normStaticBytes :: KnownNat n => StaticBytes n -> StaticBytes n normStaticBytes sb@(StaticBytes sbs) = mkStaticBytes (proxyForNatF sb) sbs@@ -100,13 +110,13 @@ x == y = let StaticBytes x' = normStaticBytes x StaticBytes y' = normStaticBytes y- in x' == y'+ in x' == y' instance KnownNat n => Ord (StaticBytes n) where compare x y = let StaticBytes x' = normStaticBytes x StaticBytes y' = normStaticBytes y- in compare x' y'+ in compare x' y' instance Default (StaticBytes n) where def = StaticBytes BSS.empty@@ -118,7 +128,7 @@ get = fmap StaticBytes (getByteString (fromInteger (natVal (Proxy :: Proxy n)))) put fb@(StaticBytes sbs) = putFixedString 0 (fromInteger (natVal fb)) sbs -newtype StaticSeq (n :: Nat) a = StaticSeq { unStaticSeq :: Seq a }+newtype StaticSeq (n :: Nat) a = StaticSeq {unStaticSeq :: Seq a} deriving stock (Show) deriving newtype (Eq, Functor, Foldable) deriving (ByteSized) via (ViaStaticByteSized (StaticSeq n a))@@ -133,7 +143,7 @@ get = fmap StaticSeq (getStaticSeq (fromIntegral (natVal (Proxy :: Proxy n))) get) put = unsafePutStaticSeqN (fromIntegral (natVal (Proxy :: Proxy n))) (Just def) put . unStaticSeq -newtype StaticArray (n :: Nat) a = StaticArray { unStaticArray :: PrimArray a }+newtype StaticArray (n :: Nat) a = StaticArray {unStaticArray :: PrimArray a} deriving stock (Show) deriving newtype (Eq) deriving (ByteSized) via (ViaStaticByteSized (StaticArray n a))@@ -148,7 +158,7 @@ get = fmap StaticArray (getStaticArray (fromIntegral (natVal (Proxy :: Proxy n)))) put = unsafePutStaticArrayN (fromIntegral (natVal (Proxy :: Proxy n))) (Just def) . unStaticArray -newtype BoolByte = BoolByte { unBoolByte :: Bool }+newtype BoolByte = BoolByte {unBoolByte :: Bool} deriving stock (Show) deriving newtype (Eq) deriving (ByteSized) via (ViaStaticByteSized BoolByte)@@ -163,7 +173,7 @@ get = fmap (BoolByte . (/= 0)) getWord8 put (BoolByte b) = putWord8 (if b then 1 else 0) -newtype ExactBytes (s :: Symbol) = ExactBytes { unExactBytes :: () }+newtype ExactBytes (s :: Symbol) = ExactBytes {unExactBytes :: ()} deriving stock (Show) deriving newtype (Eq) deriving (ByteSized) via (ViaStaticByteSized (ExactBytes s))
src/Dahdit/Free.hs view
@@ -12,11 +12,26 @@ , PutF (..) , PutM (..) , Put- ) where+ )+where import Control.Monad.Free.Church (F (..))-import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE, Int24BE, Int24LE, Int32BE, Int32LE, Word16BE, Word16LE,- Word24BE, Word24LE, Word32BE, Word32LE)+import Dahdit.Nums+ ( FloatBE+ , FloatLE+ , Int16BE+ , Int16LE+ , Int24BE+ , Int24LE+ , Int32BE+ , Int32LE+ , Word16BE+ , Word16LE+ , Word24BE+ , Word24LE+ , Word32BE+ , Word32LE+ ) import Dahdit.Sizes (ByteCount, ElementCount, StaticByteSized (..)) import Data.ByteString.Short (ShortByteString) import Data.Int (Int8)@@ -50,13 +65,13 @@ instance Functor GetScopeF where fmap f (GetScopeF sm bc g k) = GetScopeF sm bc g (f . k) -data ScopeMode =- ScopeModeExact+data ScopeMode+ = ScopeModeExact | ScopeModeWithin deriving stock (Eq, Show) -data GetF a =- GetFWord8 (Word8 -> a)+data GetF a+ = GetFWord8 (Word8 -> a) | GetFInt8 (Int8 -> a) | GetFWord16LE (Word16LE -> a) | GetFInt16LE (Int16LE -> a)@@ -83,7 +98,7 @@ | GetFFail !String deriving stock (Functor) -newtype Get a = Get { unGet :: F GetF a }+newtype Get a = Get {unGet :: F GetF a} deriving newtype (Functor, Applicative, Monad) instance MonadFail Get where@@ -107,8 +122,8 @@ instance Functor PutStaticHintF where fmap f (PutStaticHintF n p k) = PutStaticHintF n p (f k) -data PutF a =- PutFWord8 !Word8 a+data PutF a+ = PutFWord8 !Word8 a | PutFInt8 !Int8 a | PutFWord16LE !Word16LE a | PutFInt16LE !Int16LE a@@ -131,7 +146,7 @@ | PutFStaticHint !(PutStaticHintF a) deriving stock (Functor) -newtype PutM a = PutM { unPutM :: F PutF a }+newtype PutM a = PutM {unPutM :: F PutF a} deriving newtype (Functor, Applicative, Monad) instance Semigroup (PutM ()) where
src/Dahdit/Funs.hs view
@@ -60,16 +60,43 @@ , putByteArray , putLiftedPrimArray , putStaticHint- ) where+ )+where import Control.Monad (replicateM_, unless) import Control.Monad.Free.Church (F (..))-import Dahdit.Free (Get (..), GetF (..), GetLookAheadF (..), GetScopeF (..), GetStaticArrayF (..), GetStaticSeqF (..),- Put, PutF (..), PutM (..), PutStaticArrayF (..), PutStaticHintF (..), PutStaticSeqF (..),- ScopeMode (..))+import Dahdit.Free+ ( Get (..)+ , GetF (..)+ , GetLookAheadF (..)+ , GetScopeF (..)+ , GetStaticArrayF (..)+ , GetStaticSeqF (..)+ , Put+ , PutF (..)+ , PutM (..)+ , PutStaticArrayF (..)+ , PutStaticHintF (..)+ , PutStaticSeqF (..)+ , ScopeMode (..)+ ) import Dahdit.LiftedPrim (LiftedPrim (..), LiftedPrimArray (..))-import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE, Int24BE, Int24LE, Int32BE, Int32LE, Word16BE, Word16LE,- Word24BE, Word24LE, Word32BE, Word32LE)+import Dahdit.Nums+ ( FloatBE+ , FloatLE+ , Int16BE+ , Int16LE+ , Int24BE+ , Int24LE+ , Int32BE+ , Int32LE+ , Word16BE+ , Word16LE+ , Word24BE+ , Word24LE+ , Word32BE+ , Word32LE+ ) import Dahdit.Proxy (proxyForF, proxyForFun) import Dahdit.Sizes (ByteCount (..), ElementCount (..), StaticByteSized (..)) import Data.ByteString.Short (ShortByteString)@@ -146,7 +173,8 @@ -- | Get Seq of dynamically-sized elements getSeq :: ElementCount -> Get a -> Get (Seq a)-getSeq ec g = go Empty 0 where+getSeq ec g = go Empty 0+ where go !acc i = if i == ec then pure acc@@ -168,7 +196,7 @@ getLiftedPrimArray :: LiftedPrim a => Proxy a -> ElementCount -> Get (LiftedPrimArray a) getLiftedPrimArray prox ec = let !bc = fromIntegral (elemSizeLifted prox * fromIntegral ec)- in fmap LiftedPrimArray (getByteArray bc)+ in fmap LiftedPrimArray (getByteArray bc) getLookAhead :: Get a -> Get a getLookAhead g = Get (F (\x y -> y (GetFLookAhead (GetLookAheadF g x))))@@ -180,7 +208,8 @@ getRemainingString = getRemainingSize >>= getByteString getRemainingSeq :: Get a -> Get (Seq a)-getRemainingSeq g = go Empty where+getRemainingSeq g = go Empty+ where go !acc = do bc <- getRemainingSize if bc == 0@@ -228,11 +257,13 @@ getExpect :: (Eq a, Show a) => String -> Get a -> a -> Get () getExpect typ getter expec = do actual <- getter- unless (expec == actual)- (fail ("Expected " ++ " " ++ typ ++ " " ++ show expec ++ " but found " ++ show actual))+ unless+ (expec == actual)+ (fail ("Expected " ++ " " ++ typ ++ " " ++ show expec ++ " but found " ++ show actual)) getUnfold :: b -> (b -> Get (Either b a)) -> Get a-getUnfold b0 f = go b0 where+getUnfold b0 f = go b0+ where go !b = do eba <- f b either go pure eba@@ -288,7 +319,7 @@ putByteString :: ShortByteString -> Put putByteString sbs = let !bc = fromIntegral (BSS.length sbs)- in PutM (F (\x y -> y (PutFShortByteString bc sbs (x ()))))+ in PutM (F (\x y -> y (PutFShortByteString bc sbs (x ())))) putFixedString :: Word8 -> ByteCount -> ShortByteString -> Put putFixedString pad bc sbs = do@@ -309,7 +340,7 @@ putStaticSeq :: StaticByteSized a => (a -> Put) -> Seq a -> Put putStaticSeq p s = let !n = fromIntegral (Seq.length s)- in unsafePutStaticSeqN n Nothing p s+ in unsafePutStaticSeqN n Nothing p s unsafePutStaticSeqN :: StaticByteSized a => ElementCount -> Maybe a -> (a -> Put) -> Seq a -> Put unsafePutStaticSeqN n mz p s = PutM (F (\x y -> y (PutFStaticSeq (PutStaticSeqF n mz p s (x ())))))@@ -318,7 +349,7 @@ putStaticArray :: (StaticByteSized a, Prim a) => PrimArray a -> Put putStaticArray a = let !n = fromIntegral (sizeofPrimArray a)- in unsafePutStaticArrayN n Nothing a+ in unsafePutStaticArrayN n Nothing a unsafePutStaticArrayN :: (StaticByteSized a, Prim a) => ElementCount -> Maybe a -> PrimArray a -> Put unsafePutStaticArrayN n mz a = PutM (F (\x y -> y (PutFStaticArray (PutStaticArrayF n mz a (x ())))))@@ -326,7 +357,7 @@ putByteArray :: ByteArray -> Put putByteArray arr = let !bc = fromIntegral (sizeofByteArray arr)- in PutM (F (\x y -> y (PutFByteArray bc arr (x ()))))+ in PutM (F (\x y -> y (PutFByteArray bc arr (x ())))) putLiftedPrimArray :: LiftedPrimArray a -> Put putLiftedPrimArray = putByteArray . unLiftedPrimArray@@ -334,4 +365,4 @@ 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 ())))))+ in \a -> PutM (F (\x y -> y (PutFStaticHint (PutStaticHintF bc (p a) (x ())))))
src/Dahdit/Generic.hs view
@@ -3,7 +3,8 @@ module Dahdit.Generic ( ViaGeneric (..) , ViaStaticGeneric (..)- ) where+ )+where import Control.Applicative (liftA2) import Dahdit.Binary (Binary (..))@@ -12,13 +13,13 @@ import Dahdit.Sizes (ByteCount, ByteSized (..), StaticByteSized (..)) import Data.Kind (Type) import Data.Proxy (Proxy (..))-import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..), U1 (..))+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..)) -- | Use: deriving (ByteSized, Binary) via (ViaGeneric Foo)-newtype ViaGeneric a = ViaGeneric { unViaGeneric :: a }+newtype ViaGeneric a = ViaGeneric {unViaGeneric :: a} -- | Use: deriving (ByteSized, StaticByteSized, Binary) via (ViaStaticGeneric Foo)-newtype ViaStaticGeneric a = ViaStaticGeneric { unViaStaticGeneric :: a }+newtype ViaStaticGeneric a = ViaStaticGeneric {unViaStaticGeneric :: a} -- ByteSized:
src/Dahdit/Internal.hs view
@@ -6,7 +6,7 @@ import Data.Word (Word16, Word32, Word8) import GHC.Float (castFloatToWord32, castWord32ToFloat) -newtype ViaFromIntegral x y = ViaFromIntegral { unViaFromIntegral :: y }+newtype ViaFromIntegral x y = ViaFromIntegral {unViaFromIntegral :: y} deriving newtype (Num) -- Types that can swap endianness - swapEndian is its own inverse@@ -25,28 +25,28 @@ instance SwapEndian Word16 where swapEndian w = let (b0, b1) = unMkWord16LE w- in mkWord16LE b1 b0+ in mkWord16LE b1 b0 deriving via (ViaFromIntegral Word16 Int16) instance SwapEndian Int16 instance SwapEndian Word24 where swapEndian w = let (b0, b1, b2) = unMkWord24LE w- in mkWord24LE b2 b1 b0+ 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- in mkWord32LE b3 b2 b1 b0+ in mkWord32LE b3 b2 b1 b0 deriving via (ViaFromIntegral Word32 Int32) instance SwapEndian Int32 instance SwapEndian Float where swapEndian w = let (b0, b1, b2, b3) = unMkFloatLE w- in mkFloatLE b3 b2 b1 b0+ in mkFloatLE b3 b2 b1 b0 mkWord16LE :: Word8 -> Word8 -> Word16 mkWord16LE b0 b1 = (fromIntegral b1 `unsafeShiftL` 8) .|. fromIntegral b0@@ -55,7 +55,7 @@ unMkWord16LE w = let !b0 = fromIntegral w !b1 = fromIntegral (w `shiftR` 8)- in (b0, b1)+ in (b0, b1) mkWord24LE :: Word8 -> Word8 -> Word8 -> Word24 mkWord24LE b0 b1 b2 = fromIntegral (mkWord32LE b0 b1 b2 0)@@ -64,12 +64,14 @@ unMkWord24LE w = let !v = fromIntegral w (b0, b1, b2, _) = unMkWord32LE v- in (b0, b1, b2)+ in (b0, b1, b2) mkWord32LE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32 mkWord32LE b0 b1 b2 b3 =- (fromIntegral b3 `unsafeShiftL` 24) .|. (fromIntegral b2 `unsafeShiftL` 16) .|.- (fromIntegral b1 `unsafeShiftL` 8) .|. fromIntegral b0+ (fromIntegral b3 `unsafeShiftL` 24)+ .|. (fromIntegral b2 `unsafeShiftL` 16)+ .|. (fromIntegral b1 `unsafeShiftL` 8)+ .|. fromIntegral b0 unMkWord32LE :: Word32 -> (Word8, Word8, Word8, Word8) unMkWord32LE w =@@ -77,7 +79,7 @@ !b1 = fromIntegral (w `shiftR` 8) !b2 = fromIntegral (w `shiftR` 16) !b3 = fromIntegral (w `shiftR` 24)- in (b0, b1, b2, b3)+ in (b0, b1, b2, b3) mkFloatLE :: Word8 -> Word8 -> Word8 -> Word8 -> Float mkFloatLE b0 b1 b2 b3 = castWord32ToFloat (mkWord32LE b0 b1 b2 b3)
src/Dahdit/LiftedPrim.hs view
@@ -14,7 +14,8 @@ , generateLiftedPrimArray , sizeofLiftedPrimArray , cloneLiftedPrimArray- ) where+ )+where import Control.Monad.Primitive (PrimMonad (..)) import Dahdit.Internal (ViaFromIntegral (..))@@ -22,9 +23,21 @@ import Data.Default (Default (..)) 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.ByteArray+ ( ByteArray+ , MutableByteArray+ , cloneByteArray+ , emptyByteArray+ , freezeByteArray+ , indexByteArray+ , newByteArray+ , runByteArray+ , sizeofByteArray+ , thawByteArray+ , unsafeFreezeByteArray+ , unsafeThawByteArray+ , writeByteArray+ ) import Data.Proxy (Proxy (..)) import Data.STRef (modifySTRef', newSTRef, readSTRef) import Data.Word (Word8)@@ -37,12 +50,12 @@ indexByteArrayLiftedInElems :: ByteArray -> Int -> a indexByteArrayLiftedInElems arr pos = let !sz = elemSizeLifted (Proxy :: Proxy a)- in indexByteArrayLiftedInBytes arr (pos * sz)+ 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)+ in writeByteArrayLiftedInBytes val arr (pos * sz) instance LiftedPrim Word8 where elemSizeLifted _ = 1@@ -62,14 +75,14 @@ indexByteArrayLiftedInBytes arr pos = ViaFromIntegral (fromIntegral (indexByteArrayLiftedInBytes arr pos :: x)) writeByteArrayLiftedInBytes val arr pos = let !x = fromIntegral (unViaFromIntegral val) :: x in writeByteArrayLiftedInBytes x arr pos -newtype LiftedPrimArray a = LiftedPrimArray { unLiftedPrimArray :: ByteArray }+newtype LiftedPrimArray a = LiftedPrimArray {unLiftedPrimArray :: ByteArray} deriving stock (Show) deriving newtype (Eq, Semigroup, Monoid) instance Default (LiftedPrimArray a) where def = emptyLiftedPrimArray -newtype MutableLiftedPrimArray m a = MutableLiftedPrimArray { unMutableLiftedPrimArray :: MutableByteArray m }+newtype MutableLiftedPrimArray m a = MutableLiftedPrimArray {unMutableLiftedPrimArray :: MutableByteArray m} deriving newtype (Eq) emptyLiftedPrimArray :: LiftedPrimArray a@@ -102,7 +115,7 @@ for_ xs $ \x -> do off <- readSTRef offRef writeByteArrayLiftedInBytes x arr off- modifySTRef' offRef (elemSize+)+ modifySTRef' offRef (elemSize +) pure arr liftedPrimArrayFromList :: LiftedPrim a => [a] -> LiftedPrimArray a@@ -115,7 +128,7 @@ sizeofLiftedPrimArray pa@(LiftedPrimArray arr) = let !elemSize = elemSizeLifted (proxyForF pa) !arrSize = sizeofByteArray arr- in div arrSize elemSize+ in div arrSize elemSize cloneLiftedPrimArray :: LiftedPrim a => LiftedPrimArray a -> Int -> Int -> LiftedPrimArray a cloneLiftedPrimArray pa@(LiftedPrimArray arr) off len =@@ -123,4 +136,4 @@ !byteOff = off * elemSize !byteLen = len * elemSize !arr' = cloneByteArray arr byteOff byteLen- in LiftedPrimArray arr'+ in LiftedPrimArray arr'
src/Dahdit/Nums.hs view
@@ -19,10 +19,21 @@ , Word32BE (..) , Int32BE (..) , FloatBE (..)- ) where+ )+where -import Dahdit.Internal (ViaFromIntegral (..), mkFloatLE, mkWord16LE, mkWord24LE, mkWord32LE, swapEndian, unMkFloatLE,- unMkWord16LE, unMkWord24LE, unMkWord32LE)+import Dahdit.Internal+ ( ViaFromIntegral (..)+ , mkFloatLE+ , mkWord16LE+ , mkWord24LE+ , mkWord32LE+ , swapEndian+ , unMkFloatLE+ , unMkWord16LE+ , unMkWord24LE+ , unMkWord32LE+ ) import Dahdit.LiftedPrim (LiftedPrim (..)) import Data.Bits (Bits (..)) import Data.Default (Default (..))@@ -37,7 +48,7 @@ toLittleEndian :: be -> le toBigEndian :: le -> be -newtype Word16LE = Word16LE { unWord16LE :: Word16 }+newtype Word16LE = Word16LE {unWord16LE :: Word16} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim) @@ -47,18 +58,18 @@ indexByteArrayLiftedInBytes arr pos = let !b0 = indexByteArray arr pos !b1 = indexByteArray arr (pos + 1)- in Word16LE (mkWord16LE b0 b1)+ 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+ in writeByteArray arr pos b0 *> writeByteArray arr (pos + 1) b1 -newtype Int16LE = Int16LE { unInt16LE :: Int16 }+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) -newtype Word24LE = Word24LE { unWord24LE :: Word24 }+newtype Word24LE = Word24LE {unWord24LE :: Word24} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits) @@ -72,7 +83,7 @@ let !b0 = indexByteArray arr pos !b1 = indexByteArray arr (pos + 1) !b2 = indexByteArray arr (pos + 2)- in Word24LE (mkWord24LE b0 b1 b2)+ in Word24LE (mkWord24LE b0 b1 b2) writeByteArrayLiftedInBytes w arr pos = do let !(b0, b1, b2) = unMkWord24LE (unWord24LE w)@@ -80,7 +91,7 @@ writeByteArray arr (pos + 1) b1 writeByteArray arr (pos + 2) b2 -newtype Int24LE = Int24LE { unInt24LE :: Int24 }+newtype Int24LE = Int24LE {unInt24LE :: Int24} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits) deriving (LiftedPrim) via (ViaFromIntegral Word24LE Int24LE)@@ -88,7 +99,7 @@ instance Default Int24LE where def = 0 -newtype Word32LE = Word32LE { unWord32LE :: Word32 }+newtype Word32LE = Word32LE {unWord32LE :: Word32} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default, Prim) @@ -100,7 +111,7 @@ !b1 = indexByteArray arr (pos + 1) !b2 = indexByteArray arr (pos + 2) !b3 = indexByteArray arr (pos + 3)- in Word32LE (mkWord32LE b0 b1 b2 b3)+ in Word32LE (mkWord32LE b0 b1 b2 b3) writeByteArrayLiftedInBytes w arr pos = do let !(b0, b1, b2, b3) = unMkWord32LE (unWord32LE w)@@ -109,12 +120,12 @@ writeByteArray arr (pos + 2) b2 writeByteArray arr (pos + 3) b3 -newtype Int32LE = Int32LE { unInt32LE :: Int32 }+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) -newtype FloatLE = FloatLE { unFloatLE :: Float }+newtype FloatLE = FloatLE {unFloatLE :: Float} deriving stock (Show) deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default, Prim) @@ -126,7 +137,7 @@ !b1 = indexByteArray arr (pos + 1) !b2 = indexByteArray arr (pos + 2) !b3 = indexByteArray arr (pos + 3)- in FloatLE (mkFloatLE b0 b1 b2 b3)+ in FloatLE (mkFloatLE b0 b1 b2 b3) writeByteArrayLiftedInBytes f arr pos = do let !(b0, b1, b2, b3) = unMkFloatLE (unFloatLE f)@@ -135,17 +146,17 @@ writeByteArray arr (pos + 2) b2 writeByteArray arr (pos + 3) b3 -newtype Word16BE = Word16BE { unWord16BE :: Word16 }+newtype Word16BE = Word16BE {unWord16BE :: Word16} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default) deriving (LiftedPrim) via (ViaEndianPair Word16LE Word16BE) -newtype Int16BE = Int16BE { unInt16BE :: Int16 }+newtype Int16BE = Int16BE {unInt16BE :: Int16} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default) deriving (LiftedPrim) via (ViaEndianPair Int16LE Int16BE) -newtype Word24BE = Word24BE { unWord24BE :: Word24 }+newtype Word24BE = Word24BE {unWord24BE :: Word24} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits) deriving (LiftedPrim) via (ViaEndianPair Word24LE Word24BE)@@ -153,7 +164,7 @@ instance Default Word24BE where def = 0 -newtype Int24BE = Int24BE { unInt24BE :: Int24 }+newtype Int24BE = Int24BE {unInt24BE :: Int24} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits) deriving (LiftedPrim) via (ViaEndianPair Int24LE Int24BE)@@ -161,17 +172,17 @@ instance Default Int24BE where def = 0 -newtype Word32BE = Word32BE { unWord32BE :: Word32 }+newtype Word32BE = Word32BE {unWord32BE :: Word32} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default) deriving (LiftedPrim) via (ViaEndianPair Word32LE Word32BE) -newtype Int32BE = Int32BE { unInt32BE :: Int32 }+newtype Int32BE = Int32BE {unInt32BE :: Int32} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bits, Default) deriving (LiftedPrim) via (ViaEndianPair Int32LE Int32BE) -newtype FloatBE = FloatBE { unFloatBE :: Float }+newtype FloatBE = FloatBE {unFloatBE :: Float} deriving stock (Show) deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default, Prim) deriving (LiftedPrim) via (ViaEndianPair FloatLE FloatBE)@@ -212,7 +223,7 @@ toLittleEndian = FloatLE . swapEndian . unFloatBE toBigEndian = FloatBE . swapEndian . unFloatLE -newtype ViaEndianPair le be = ViaEndianPair { unViaEndianPair :: be }+newtype ViaEndianPair le be = ViaEndianPair {unViaEndianPair :: be} instance (LiftedPrim le, EndianPair le be) => LiftedPrim (ViaEndianPair le be) where elemSizeLifted _ = elemSizeLifted (Proxy :: Proxy le)
src/Dahdit/Proxy.hs view
@@ -3,7 +3,8 @@ , proxyForF , proxyForFun , proxyForNatF- ) where+ )+where import Data.Proxy (Proxy (..)) import GHC.TypeLits (Nat)
src/Dahdit/Run.hs view
@@ -7,7 +7,8 @@ , runCount , runPut , runPutFile- ) where+ )+where import Control.Applicative (Alternative (..)) import Control.Exception (Exception (..), throwIO)@@ -21,12 +22,38 @@ import Control.Monad.Trans (lift) import Control.Monad.Trans.Free (FreeT (..), iterT, wrap) import Control.Monad.Trans.Maybe (MaybeT (..))-import Dahdit.Free (Get (..), GetF (..), GetLookAheadF (..), GetScopeF (..), GetStaticArrayF (..), GetStaticSeqF (..),- Put, PutF (..), PutM (..), PutStaticArrayF (..), PutStaticHintF (..), PutStaticSeqF (..),- ScopeMode (..))+import Dahdit.Free+ ( Get (..)+ , GetF (..)+ , GetLookAheadF (..)+ , GetScopeF (..)+ , GetStaticArrayF (..)+ , GetStaticSeqF (..)+ , Put+ , PutF (..)+ , PutM (..)+ , PutStaticArrayF (..)+ , PutStaticHintF (..)+ , PutStaticSeqF (..)+ , ScopeMode (..)+ ) import Dahdit.LiftedPrim (LiftedPrim (..))-import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE (..), Int24BE, Int24LE, Int32BE, Int32LE, Word16BE,- Word16LE (..), Word24BE, Word24LE, Word32BE, Word32LE)+import Dahdit.Nums+ ( FloatBE+ , FloatLE+ , Int16BE+ , Int16LE (..)+ , Int24BE+ , Int24LE+ , Int32BE+ , Int32LE+ , Word16BE+ , Word16LE (..)+ , Word24BE+ , Word24LE+ , Word32BE+ , Word32LE+ ) import Dahdit.Proxy (proxyForF) import Dahdit.Sizes (ByteCount (..), staticByteSize) import qualified Data.ByteString as BS@@ -35,11 +62,20 @@ 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.ByteArray+ ( ByteArray (..)+ , MutableByteArray+ , cloneByteArray+ , copyByteArray+ , indexByteArray+ , newByteArray+ , setByteArray+ , unsafeFreezeByteArray+ , writeByteArray+ ) import Data.Primitive.PrimArray (PrimArray (..), sizeofPrimArray)-import qualified Data.Sequence as Seq import Data.STRef.Strict (STRef, newSTRef, readSTRef, writeSTRef)+import qualified Data.Sequence as Seq import Data.Word (Word8) -- Sizes:@@ -47,17 +83,17 @@ getStaticSeqSize :: GetStaticSeqF a -> Int getStaticSeqSize (GetStaticSeqF ec g _) = let !z = fromIntegral (staticByteSize (proxyForF g))- in z * fromIntegral ec+ in z * fromIntegral ec getStaticArraySize :: GetStaticArrayF a -> Int getStaticArraySize (GetStaticArrayF n prox _) = let !z = fromIntegral (staticByteSize prox)- in z * fromIntegral n+ in z * fromIntegral n putStaticSeqSize :: PutStaticSeqF a -> Int putStaticSeqSize (PutStaticSeqF n _ _ s _) = let !z = fromIntegral (staticByteSize (proxyForF s))- in z * fromIntegral n+ in z * fromIntegral n putStaticArrayElemSize :: PutStaticArrayF a -> Int putStaticArrayElemSize (PutStaticArrayF _ _ a _) =@@ -66,12 +102,12 @@ putStaticArraySize :: PutStaticArrayF a -> Int putStaticArraySize (PutStaticArrayF n _ a _) = let !z = fromIntegral (staticByteSize (proxyForF a))- in z * fromIntegral n+ in z * fromIntegral n -- Get: -data GetError =- GetErrorParseNeed !String !ByteCount !ByteCount+data GetError+ = GetErrorParseNeed !String !ByteCount !ByteCount | GetErrorScopedMismatch !ByteCount !ByteCount | GetErrorFail !String deriving stock (Eq, Show)@@ -97,7 +133,7 @@ pos <- newSTRef 0 pure $! GetEnv len pos (ByteArray arr) -newtype GetEff s a = GetEff { unGetEff :: ReaderT (GetEnv s) (ExceptT GetError (ST s)) a }+newtype GetEff s a = GetEff {unGetEff :: ReaderT (GetEnv s) (ExceptT GetError (ST s)) a} deriving newtype (Functor, Applicative, Monad, MonadReader (GetEnv s), MonadError GetError) runGetEff :: GetEff s a -> GetEnv s -> ST s (Either GetError a)@@ -109,7 +145,7 @@ stGetEff :: ST s a -> GetEff s a stGetEff = GetEff . lift . lift -newtype GetRun s a = GetRun { unGetRun :: FreeT GetF (GetEff s) a }+newtype GetRun s a = GetRun {unGetRun :: FreeT GetF (GetEff s) a} deriving newtype (Functor, Applicative, Monad) guardReadBytes :: String -> Int -> GetEff s Int@@ -144,7 +180,7 @@ then throwError (GetErrorParseNeed "scope" (fromIntegral oldAvail) bc) else do let !newLen = oldPos + intBc- a <- local (\ge -> ge { geLen = newLen }) (mkGetEff g)+ a <- local (\ge -> ge {geLen = newLen}) (mkGetEff g) case sm of ScopeModeWithin -> k a ScopeModeExact -> do@@ -195,12 +231,12 @@ GetFFloatBE k -> readBytes "FloatBE" 4 (indexByteArrayLiftedInBytes @FloatBE) >>= k GetFShortByteString bc k -> let !len = fromIntegral bc- in readBytes "ShortByteString" len (readShortByteString len) >>= k+ in readBytes "ShortByteString" len (readShortByteString len) >>= 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+ in readBytes "ByteArray" len (\arr pos -> cloneByteArray arr pos len) >>= k GetFScope gs -> readScope gs GetFSkip bc k -> readBytes "skip" (fromIntegral bc) (\_ _ -> ()) *> k GetFLookAhead gla -> readLookAhead gla@@ -234,9 +270,9 @@ 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)+ in case ea of+ Left e -> throwIO e+ Right a -> pure (a, bc) runGetFile :: Get a -> FilePath -> IO (a, ByteCount) runGetFile m fp = do@@ -255,7 +291,7 @@ newPutEnv :: Int -> ST s (PutEnv s) newPutEnv len = PutEnv len <$> newSTRef 0 <*> newByteArray len -newtype PutEff s a = PutEff { unPutEff :: ReaderT (PutEnv s) (ST s) a }+newtype PutEff s a = PutEff {unPutEff :: ReaderT (PutEnv s) (ST s) a} deriving newtype (Functor, Applicative, Monad, MonadReader (PutEnv s)) runPutEff :: PutEff s a -> PutEnv s -> ST s a@@ -264,7 +300,7 @@ stPutEff :: ST s a -> PutEff s a stPutEff = PutEff . lift -newtype PutRun s a = PutRun { unPutRun :: FreeT PutF (PutEff s) a }+newtype PutRun s a = PutRun {unPutRun :: FreeT PutF (PutEff s) a} deriving newtype (Functor, Applicative, Monad) writeBytes :: Int -> (MutableByteArray s -> Int -> ST s ()) -> PutEff s ()@@ -324,12 +360,12 @@ PutFFloatBE x k -> writeBytes 4 (writeByteArrayLiftedInBytes x) *> k PutFShortByteString bc sbs k -> let !len = fromIntegral bc- in writeBytes len (writeShortByteString sbs len) *> k+ in writeBytes len (writeShortByteString sbs len) *> 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+ in writeBytes len (\arr pos -> copyByteArray arr pos barr 0 len) *> k PutFStaticHint (PutStaticHintF _ p k) -> mkPutEff p *> k runPutRun :: PutRun s a -> PutEnv s -> ST s a@@ -357,48 +393,48 @@ -- Count: -newtype CountEff a = CountEff { unCountEff :: MaybeT (State Int) a }+newtype CountEff a = CountEff {unCountEff :: MaybeT (State Int) a} deriving newtype (Functor, Applicative, Monad, Alternative, MonadState Int) runCountEff :: CountEff a -> Int -> (Maybe a, Int) runCountEff m = runState (runMaybeT (unCountEff m)) -newtype CountRun a = CountRun { unCountRun :: FreeT PutF CountEff a }+newtype CountRun a = CountRun {unCountRun :: FreeT PutF CountEff a} deriving newtype (Functor, Applicative, Monad) execCountRun :: PutF (CountEff a) -> CountEff a execCountRun = \case- PutFWord8 _ k -> State.modify' (1+) *> k- PutFInt8 _ k -> State.modify' (1+) *> k- PutFWord16LE _ k -> State.modify' (2+) *> k- PutFInt16LE _ k -> State.modify' (2+) *> k- PutFWord24LE _ k -> State.modify' (3+) *> k- PutFInt24LE _ k -> State.modify' (3+) *> k- PutFWord32LE _ k -> State.modify' (4+) *> k- PutFInt32LE _ k -> State.modify' (4+) *> k- PutFFloatLE _ k -> State.modify' (4+) *> 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- PutFFloatBE _ k -> State.modify' (4+) *> k+ PutFWord8 _ k -> State.modify' (1 +) *> k+ PutFInt8 _ k -> State.modify' (1 +) *> k+ PutFWord16LE _ k -> State.modify' (2 +) *> k+ PutFInt16LE _ k -> State.modify' (2 +) *> k+ PutFWord24LE _ k -> State.modify' (3 +) *> k+ PutFInt24LE _ k -> State.modify' (3 +) *> k+ PutFWord32LE _ k -> State.modify' (4 +) *> k+ PutFInt32LE _ k -> State.modify' (4 +) *> k+ PutFFloatLE _ k -> State.modify' (4 +) *> 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+ PutFFloatBE _ k -> State.modify' (4 +) *> k PutFShortByteString bc _ k -> let !len = fromIntegral bc- in State.modify' (len+) *> k+ in State.modify' (len +) *> k PutFStaticSeq pss@(PutStaticSeqF _ _ _ _ k) -> let !len = putStaticSeqSize pss- in State.modify' (len+) *> k+ in State.modify' (len +) *> k PutFStaticArray psv@(PutStaticArrayF _ _ _ k) -> let !len = putStaticArraySize psv- in State.modify' (len+) *> k+ in State.modify' (len +) *> k PutFByteArray bc _ k -> let !len = fromIntegral bc- in State.modify' (len+) *> k+ in State.modify' (len +) *> k PutFStaticHint (PutStaticHintF bc _ k) -> let !len = fromIntegral bc- in State.modify' (len+) *> k+ in State.modify' (len +) *> k runCountRun :: CountRun a -> Int -> (Maybe a, Int) runCountRun = runCountEff . iterCountRun@@ -416,7 +452,7 @@ runCount m = let !n = mkCountRun m (_, !bc) = runCountRun n 0- in fromIntegral bc+ in fromIntegral bc -- Put safe: @@ -429,4 +465,4 @@ runPutFile fp m = let !bs = runPut m !bs' = BSS.fromShort bs- in BS.writeFile fp bs'+ in BS.writeFile fp bs'
src/Dahdit/Sizes.hs view
@@ -7,11 +7,26 @@ , ViaStaticByteSized (..) , byteSizeFoldable , staticByteSizeFoldable- ) where+ )+where import Dahdit.LiftedPrim (LiftedPrim, LiftedPrimArray, sizeofLiftedPrimArray)-import Dahdit.Nums (FloatBE, FloatLE, Int16BE, Int16LE, Int24BE, Int24LE, Int32BE, Int32LE, Word16BE, Word16LE,- Word24BE, Word24LE, Word32BE, Word32LE)+import Dahdit.Nums+ ( FloatBE+ , FloatLE+ , Int16BE+ , Int16LE+ , Int24BE+ , Int24LE+ , Int32BE+ , Int32LE+ , Word16BE+ , Word16LE+ , Word24BE+ , Word24LE+ , Word32BE+ , Word32LE+ ) import Dahdit.Proxy (proxyFor, proxyForF) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS@@ -26,11 +41,11 @@ import qualified Data.Sequence as Seq import Data.Word (Word16, Word32, Word64, Word8) -newtype ElementCount = ElementCount { unElementCount :: Word64 }+newtype ElementCount = ElementCount {unElementCount :: Word64} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bounded, Default) -newtype ByteCount = ByteCount { unByteCount :: Word64 }+newtype ByteCount = ByteCount {unByteCount :: Word64} deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Bounded, Default) @@ -113,19 +128,19 @@ byteSize ss = let !elen = staticByteSize (Proxy :: Proxy a) !alen = fromIntegral (Seq.length ss)- in elen * alen+ in elen * alen instance (StaticByteSized a, Prim a) => ByteSized (PrimArray a) where byteSize pa = let !elen = staticByteSize (Proxy :: Proxy a) !alen = fromIntegral (sizeofPrimArray pa)- in elen * alen+ in elen * alen instance (StaticByteSized a, LiftedPrim a) => ByteSized (LiftedPrimArray a) where byteSize lpa = let !elen = staticByteSize (Proxy :: Proxy a) !alen = fromIntegral (sizeofLiftedPrimArray lpa)- in elen * alen+ in elen * alen class ByteSized a => StaticByteSized a where staticByteSize :: Proxy a -> ByteCount@@ -202,7 +217,7 @@ instance StaticByteSized FloatBE where staticByteSize _ = 4 -newtype ViaStaticByteSized a = ViaStaticByteSized { unViaStaticByteSized :: a }+newtype ViaStaticByteSized a = ViaStaticByteSized {unViaStaticByteSized :: a} instance StaticByteSized a => ByteSized (ViaStaticByteSized a) where byteSize _ = staticByteSize (Proxy :: Proxy a)
test/Main.hs view
@@ -1,15 +1,80 @@ module Main (main) where -import Dahdit (Binary (..), BoolByte (BoolByte), ByteCount, ByteSized (..), FloatBE (..), FloatLE (..), Generic, Get,- Int16LE, Int32LE, Int8, Proxy (..), Put, ShortByteString, StaticByteSized (..), ViaGeneric (..),- ViaStaticGeneric (..), Word16LE, Word32LE, Word8, getByteArray, getByteString, getExact, getFloatBE,- getFloatLE, getInt16BE, getInt16LE, getInt24BE, getInt24LE, getInt32BE, getInt32LE, getInt8,- getLiftedPrimArray, getLookAhead, getRemainingSize, getSeq, getSkip, getStaticArray, getStaticSeq,- getWithin, getWord16BE, getWord16LE, getWord24BE, getWord24LE, getWord32BE, getWord32LE, getWord8,- liftedPrimArrayFromList, putByteArray, putByteString, putFloatBE, putFloatLE, putInt16BE, putInt16LE,- putInt24BE, putInt24LE, putInt32BE, putInt32LE, putInt8, putLiftedPrimArray, putSeq, putStaticArray,- putStaticSeq, putWord16BE, putWord16LE, putWord24BE, putWord24LE, putWord32BE, putWord32LE, putWord8,- runCount, runGet, runPut)+import Dahdit+ ( Binary (..)+ , BoolByte (BoolByte)+ , ByteCount+ , ByteSized (..)+ , FloatBE (..)+ , FloatLE (..)+ , Generic+ , Get+ , Int16LE+ , Int32LE+ , Int8+ , Proxy (..)+ , Put+ , ShortByteString+ , StaticByteSized (..)+ , ViaGeneric (..)+ , ViaStaticGeneric (..)+ , Word16LE+ , Word32LE+ , Word8+ , getByteArray+ , getByteString+ , getExact+ , getFloatBE+ , getFloatLE+ , getInt16BE+ , getInt16LE+ , getInt24BE+ , getInt24LE+ , getInt32BE+ , getInt32LE+ , getInt8+ , getLiftedPrimArray+ , getLookAhead+ , getRemainingSize+ , getSeq+ , getSkip+ , getStaticArray+ , getStaticSeq+ , getWithin+ , getWord16BE+ , getWord16LE+ , getWord24BE+ , getWord24LE+ , getWord32BE+ , getWord32LE+ , getWord8+ , liftedPrimArrayFromList+ , putByteArray+ , putByteString+ , putFloatBE+ , putFloatLE+ , putInt16BE+ , putInt16LE+ , putInt24BE+ , putInt24LE+ , putInt32BE+ , putInt32LE+ , putInt8+ , putLiftedPrimArray+ , putSeq+ , putStaticArray+ , putStaticSeq+ , putWord16BE+ , putWord16LE+ , putWord24BE+ , putWord24LE+ , putWord32BE+ , putWord32LE+ , putWord8+ , runCount+ , runGet+ , runPut+ ) import qualified Data.ByteString.Short as BSS import Data.Primitive.ByteArray (byteArrayFromList) import Data.Primitive.PrimArray (primArrayFromList)@@ -51,112 +116,120 @@ actBc @?= expecBc testDahditByteSize :: TestTree-testDahditByteSize = 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 "ShortByteString" (byteSize @ShortByteString (BSS.pack [0xEC, 0x5D]) @?= 2)- , testCase "DynFoo" (byteSize (DynFoo 0xBB 0x5DEC) @?= 3)- , testCase "StaFoo" (byteSize (StaFoo 0xBB 0x5DEC) @?= 3)- ]+testDahditByteSize =+ 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 "ShortByteString" (byteSize @ShortByteString (BSS.pack [0xEC, 0x5D]) @?= 2)+ , testCase "DynFoo" (byteSize (DynFoo 0xBB 0x5DEC) @?= 3)+ , testCase "StaFoo" (byteSize (StaFoo 0xBB 0x5DEC) @?= 3)+ ] testDahditStaticByteSize :: TestTree-testDahditStaticByteSize = testGroup "staticByteSize"- [ testCase "Word8" (staticByteSize @Word8 Proxy @?= 1)- , testCase "Int8" (staticByteSize @Int8 Proxy @?= 1)- , testCase "Word16LE" (staticByteSize @Word16LE Proxy @?= 2)- , testCase "Int16LE" (staticByteSize @Int16LE Proxy @?= 2)- , testCase "Word32LE" (staticByteSize @Word32LE Proxy @?= 4)- , testCase "Int32LE" (staticByteSize @Int32LE Proxy @?= 4)- , testCase "FloatLE" (staticByteSize @FloatLE Proxy @?= 4)- , testCase "StaFoo" (staticByteSize @StaFoo Proxy @?= 3)- , testCase "BoolByte" (staticByteSize @BoolByte Proxy @?= 1)- ]+testDahditStaticByteSize =+ testGroup+ "staticByteSize"+ [ testCase "Word8" (staticByteSize @Word8 Proxy @?= 1)+ , testCase "Int8" (staticByteSize @Int8 Proxy @?= 1)+ , testCase "Word16LE" (staticByteSize @Word16LE Proxy @?= 2)+ , testCase "Int16LE" (staticByteSize @Int16LE Proxy @?= 2)+ , testCase "Word32LE" (staticByteSize @Word32LE Proxy @?= 4)+ , testCase "Int32LE" (staticByteSize @Int32LE Proxy @?= 4)+ , testCase "FloatLE" (staticByteSize @FloatLE Proxy @?= 4)+ , testCase "StaFoo" (staticByteSize @StaFoo Proxy @?= 3)+ , testCase "BoolByte" (staticByteSize @BoolByte Proxy @?= 1)+ ] testDahditGet :: TestTree-testDahditGet = 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])- ]+testDahditGet =+ 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])+ ] testDahditPut :: TestTree-testDahditPut = 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])- ]+testDahditPut =+ 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])+ ] testDahdit :: TestTree-testDahdit = testGroup "Dahdit" [ testDahditByteSize, testDahditStaticByteSize, testDahditGet, testDahditPut ]+testDahdit = testGroup "Dahdit" [testDahditByteSize, testDahditStaticByteSize, testDahditGet, testDahditPut] main :: IO () main = defaultMain testDahdit