diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Eric Conlon (c) 2022 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Eric Conlon nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,14 @@ * It uses `ByteArray` internally to avoid generating new or retaining references to old pinned memory. * Examining `Put` can yield required byte size without serializing. * 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. +* Types implementing `Binary` can implement `byteSized` for size calculation (or it will reflect on `put`). * Known-statically-sized types can implement `StaticByteSized` for size speedups. * Provides several additional types representing fixed-length strings or sequences (using `TypeLits`). + +## Static sizes + +You may find it necessary to discharge simple `KnownNat` constraints with a plugin like `ghc-typelits-knownnat`. +Add that package to your dependencies and add this to the top of the necessary files: + + {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} diff --git a/dahdit.cabal b/dahdit.cabal --- a/dahdit.cabal +++ b/dahdit.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: dahdit -version: 0.3.0 +version: 0.5.0 synopsis: Binary parsing and serialization with integrated size description: Please see the README on GitHub at category: Data @@ -15,7 +15,6 @@ maintainer: ejconlon@gmail.com copyright: (c) 2022 Eric Conlon license: BSD3 -license-file: LICENSE build-type: Simple tested-with: GHC == 9.2.7 @@ -31,7 +30,6 @@ Dahdit Dahdit.Binary Dahdit.BinaryRep - Dahdit.Codec Dahdit.Fancy Dahdit.Free Dahdit.Funs @@ -83,10 +81,12 @@ , data-default ==0.7.* , data-sword ==0.2.* , free ==5.1.* + , ghc-typelits-knownnat ==0.7.* , mtl ==2.2.* , primitive >=0.7 && <0.9 + , text >=1.2 && <2.1 , transformers ==0.5.* - , vector ==0.12.* + , vector >=0.12 && <0.14 default-language: Haskell2010 test-suite dahdit-test @@ -130,11 +130,14 @@ , dahdit , data-default ==0.7.* , data-sword ==0.2.* + , falsify ==0.2.* , free ==5.1.* + , ghc-typelits-knownnat ==0.7.* , mtl ==2.2.* , primitive >=0.7 && <0.9 - , tasty - , tasty-hunit + , tasty ==1.4.* + , tasty-hunit ==0.10.* + , text >=1.2 && <2.1 , transformers ==0.5.* - , vector ==0.12.* + , vector >=0.12 && <0.14 default-language: Haskell2010 diff --git a/src/Dahdit.hs b/src/Dahdit.hs --- a/src/Dahdit.hs +++ b/src/Dahdit.hs @@ -10,6 +10,8 @@ , Proxy (..) , GetError (..) , prettyGetError + , GetIncRequest (..) + , GetIncCb , runCount , module Dahdit.Binary , module Dahdit.BinaryRep @@ -37,7 +39,7 @@ import Dahdit.LiftedPrimArray import Dahdit.Nums import Dahdit.Proxy -import Dahdit.Run (GetError (..), prettyGetError, runCount) +import Dahdit.Run (GetError (..), GetIncCb, GetIncRequest (..), prettyGetError, runCount) import Dahdit.Sizes import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString) diff --git a/src/Dahdit/Binary.hs b/src/Dahdit/Binary.hs --- a/src/Dahdit/Binary.hs +++ b/src/Dahdit/Binary.hs @@ -1,5 +1,6 @@ module Dahdit.Binary ( Binary (..) + , byteSizeFoldable ) where @@ -76,9 +77,11 @@ , Word64BE (..) , Word64LE (..) ) -import Dahdit.Sizes (ElemCount (..)) +import Dahdit.Run (runCount) +import Dahdit.Sizes (ByteCount (..), ElemCount (..)) import Data.ByteString.Internal (c2w, w2c) import Data.Coerce (coerce) +import Data.Foldable (foldMap') import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -86,6 +89,7 @@ import qualified Data.IntSet as IntSet import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Semigroup (Sum (..)) import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Set (Set) @@ -94,100 +98,125 @@ import Data.Word (Word16, Word32, Word64, Word8) class Binary a where + byteSize :: a -> ByteCount + byteSize = runCount . put get :: Get a put :: a -> Put -- Basic types instance Binary () where + byteSize _ = 0 get = pure () put _ = pure () instance Binary Word8 where + byteSize _ = 1 get = getWord8 put = putWord8 instance Binary Int8 where + byteSize _ = 1 get = getInt8 put = putInt8 instance Binary Word16LE where + byteSize _ = 2 get = getWord16LE put = putWord16LE instance Binary Int16LE where + byteSize _ = 2 get = getInt16LE put = putInt16LE instance Binary Word24LE where + byteSize _ = 3 get = getWord24LE put = putWord24LE instance Binary Int24LE where + byteSize _ = 3 get = getInt24LE put = putInt24LE instance Binary Word32LE where + byteSize _ = 4 get = getWord32LE put = putWord32LE instance Binary Int32LE where + byteSize _ = 4 get = getInt32LE put = putInt32LE instance Binary Word64LE where + byteSize _ = 8 get = getWord64LE put = putWord64LE instance Binary Int64LE where + byteSize _ = 8 get = getInt64LE put = putInt64LE instance Binary FloatLE where + byteSize _ = 4 get = getFloatLE put = putFloatLE instance Binary DoubleLE where + byteSize _ = 8 get = getDoubleLE put = putDoubleLE instance Binary Word16BE where + byteSize _ = 2 get = getWord16BE put = putWord16BE instance Binary Int16BE where + byteSize _ = 2 get = getInt16BE put = putInt16BE instance Binary Word24BE where + byteSize _ = 3 get = getWord24BE put = putWord24BE instance Binary Int24BE where + byteSize _ = 3 get = getInt24BE put = putInt24BE instance Binary Word32BE where + byteSize _ = 4 get = getWord32BE put = putWord32BE instance Binary Int32BE where + byteSize _ = 4 get = getInt32BE put = putInt32BE instance Binary Word64BE where + byteSize _ = 8 get = getWord64BE put = putWord64BE instance Binary Int64BE where + byteSize _ = 8 get = getInt64BE put = putInt64BE instance Binary FloatBE where + byteSize _ = 4 get = getFloatBE put = putFloatBE instance Binary DoubleBE where + byteSize _ = 8 get = getDoubleBE put = putDoubleBE @@ -212,46 +241,58 @@ deriving via DoubleLE instance Binary Double instance Binary Bool where + byteSize _ = 1 get = fmap (/= 0) getWord8 put b = putWord8 (if b then 1 else 0) instance Binary Char where + byteSize _ = 1 get = fmap w2c getWord8 put = putWord8 . c2w instance Binary Int where + byteSize _ = 8 get = fmap fromIntegral getInt64LE put = putInt64LE . fromIntegral -instance Binary a => Binary [a] where +instance (Binary a) => Binary [a] where + byteSize as = 8 + byteSizeFoldable as 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 +instance (Binary a) => Binary (Seq a) where + byteSize as = 8 + byteSizeFoldable as 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 +instance (Binary a) => Binary (Set a) where + byteSize = byteSize . Set.toAscList get = fmap Set.fromDistinctAscList get put = put . Set.toAscList instance (Binary k, Binary v) => Binary (Map k v) where + byteSize = byteSize . Map.toAscList get = fmap Map.fromDistinctAscList get put = put . Map.toAscList instance Binary IntSet where + byteSize = byteSize . IntSet.toAscList get = fmap IntSet.fromDistinctAscList get put = put . IntSet.toAscList -instance Binary v => Binary (IntMap v) where +instance (Binary v) => Binary (IntMap v) where + byteSize = byteSize . IntMap.toAscList get = fmap IntMap.fromDistinctAscList get put = put . IntMap.toAscList -instance Binary a => Binary (Maybe a) where +instance (Binary a) => Binary (Maybe a) where + byteSize = \case + Nothing -> 1 + Just a -> 1 + byteSize a get = do tag <- get @Int case tag of @@ -263,6 +304,9 @@ Just a -> put @Int 1 *> put a instance (Binary b, Binary a) => Binary (Either b a) where + byteSize = \case + Left b -> 1 + byteSize b + Right a -> 1 + byteSize a get = do tag <- get @Int case tag of @@ -274,6 +318,7 @@ Right a -> put @Int 1 *> put a instance (Binary a, Binary b) => Binary (a, b) where + byteSize (a, b) = byteSize a + byteSize b get = do a <- get b <- get @@ -281,6 +326,7 @@ put (a, b) = put a *> put b instance (Binary a, Binary b, Binary c) => Binary (a, b, c) where + byteSize (a, b, c) = byteSize a + byteSize b + byteSize c get = do a <- get b <- get @@ -289,6 +335,7 @@ 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 + byteSize (a, b, c, d) = byteSize a + byteSize b + byteSize c + byteSize d get = do a <- get b <- get @@ -298,6 +345,7 @@ 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 + byteSize (a, b, c, d, e) = byteSize a + byteSize b + byteSize c + byteSize d + byteSize e get = do a <- get b <- get @@ -306,3 +354,6 @@ e <- get pure (a, b, c, d, e) put (a, b, c, d, e) = put a *> put b *> put c *> put d *> put e + +byteSizeFoldable :: (Foldable f, Binary a) => f a -> ByteCount +byteSizeFoldable = getSum . foldMap' (Sum . byteSize) diff --git a/src/Dahdit/BinaryRep.hs b/src/Dahdit/BinaryRep.hs --- a/src/Dahdit/BinaryRep.hs +++ b/src/Dahdit/BinaryRep.hs @@ -9,10 +9,10 @@ where import Dahdit.Binary (Binary (..)) -import Dahdit.Sizes (ByteSized (..), StaticByteSized (..)) +import Dahdit.Sizes (StaticByteSized (..)) import Data.Proxy (Proxy (..)) -class Binary x => BinaryRep x a | a -> x where +class (Binary x) => BinaryRep x a | a -> x where fromBinaryRep :: x -> Either String a toBinaryRep :: a -> x @@ -32,14 +32,13 @@ fromBinaryRep = Right . ViaIntegral . fromIntegral toBinaryRep = fromIntegral . unViaIntegral -newtype ViaBinaryRep a = ViaBinaryRep {unViaBinaryRep :: a} - -instance (ByteSized x, BinaryRep x a) => ByteSized (ViaBinaryRep a) where - byteSize = byteSize . toBinaryRep . unViaBinaryRep +newtype ViaBinaryRep x a = ViaBinaryRep {unViaBinaryRep :: a} -instance (StaticByteSized x, BinaryRep x a) => StaticByteSized (ViaBinaryRep a) where +instance (StaticByteSized x, BinaryRep x a) => StaticByteSized (ViaBinaryRep x a) where + type StaticSize (ViaBinaryRep x a) = StaticSize x staticByteSize _ = staticByteSize (Proxy :: Proxy x) -instance BinaryRep x a => Binary (ViaBinaryRep a) where +instance (BinaryRep x a) => Binary (ViaBinaryRep x a) where + byteSize = byteSize . toBinaryRep . unViaBinaryRep get = get >>= either fail (pure . ViaBinaryRep) . fromBinaryRep put = put . toBinaryRep . unViaBinaryRep diff --git a/src/Dahdit/Codec.hs b/src/Dahdit/Codec.hs deleted file mode 100644 --- a/src/Dahdit/Codec.hs +++ /dev/null @@ -1,130 +0,0 @@ --- 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.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.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, LiftedPrim 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 HasCodec a => Binary (ViaCodec a) where - get = coerce (parse (codec @a)) - put = coerce (produce (codec @a)) diff --git a/src/Dahdit/Fancy.hs b/src/Dahdit/Fancy.hs --- a/src/Dahdit/Fancy.hs +++ b/src/Dahdit/Fancy.hs @@ -1,5 +1,10 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoStarIsType #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + module Dahdit.Fancy - ( TermBytes (..) + ( TermBytes8 (..) + , TermBytes16 (..) , StaticBytes (..) , mkStaticBytes , normStaticBytes @@ -28,7 +33,7 @@ import Dahdit.LiftedPrim (LiftedPrim) import Dahdit.LiftedPrimArray (LiftedPrimArray, replicateLiftedPrimArray) import Dahdit.Proxy (proxyForNatF) -import Dahdit.Sizes (ByteCount (..), ByteSized (..), StaticByteSized (..), ViaStaticByteSized (..)) +import Dahdit.Sizes (ByteCount (..), StaticByteSized (..), byteSizeViaStatic) import Data.ByteString.Internal (c2w) import qualified Data.ByteString.Short as BSS import Data.ByteString.Short.Internal (ShortByteString (..)) @@ -40,7 +45,7 @@ import qualified Data.Sequence as Seq import Data.String (IsString) import Data.Word (Word8) -import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) +import GHC.TypeLits (ConsSymbol, KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal, type (*), type (+)) getUntilNull :: Get (ByteCount, [Word8]) getUntilNull = go 0 [] @@ -55,30 +60,49 @@ mkSBS n bs = let !(ByteArray ba) = byteArrayFromListN (coerce n) bs in SBS ba -- | Bytes terminated with null byte. +newtype TermBytes8 = TermBytes8 {unTermBytes8 :: ShortByteString} + deriving stock (Show) + deriving newtype (Eq, Ord, IsString) + +instance Default TermBytes8 where + def = TermBytes8 BSS.empty + +instance Binary TermBytes8 where + byteSize (TermBytes8 sbs) = ByteCount (BSS.length sbs + 1) + + get = do + (i, acc) <- getUntilNull + let sbs = mkSBS i acc + pure (TermBytes8 sbs) + + put (TermBytes8 sbs) = do + putByteString sbs + putWord8 0 + +-- | 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 TermBytes16 = TermBytes16 {unTermBytes16 :: ShortByteString} deriving stock (Show) deriving newtype (Eq, Ord, IsString) -instance Default TermBytes where - def = TermBytes BSS.empty +instance Default TermBytes16 where + def = TermBytes16 BSS.empty -instance ByteSized TermBytes where - byteSize (TermBytes sbs) = - let bc = byteSize sbs + 1 +instance Binary TermBytes16 where + byteSize (TermBytes16 sbs) = + let bc = ByteCount (BSS.length sbs + 1) in if even bc then bc else bc + 1 -instance Binary TermBytes where get = do (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) + pure (TermBytes16 sbs) - put (TermBytes sbs) = do + put (TermBytes16 sbs) = do putByteString sbs putWord8 0 unless (odd (BSS.length sbs)) (putWord8 0) @@ -88,9 +112,7 @@ deriving stock (Show) deriving newtype (IsString) -deriving via (ViaStaticByteSized (StaticBytes n)) instance KnownNat n => ByteSized (StaticBytes n) - -mkStaticBytes :: KnownNat n => Proxy n -> ShortByteString -> StaticBytes n +mkStaticBytes :: (KnownNat n) => Proxy n -> ShortByteString -> StaticBytes n mkStaticBytes prox sbs = let n = fromInteger (natVal prox) in if BSS.length sbs == n @@ -103,16 +125,16 @@ then x1 else x1 <> BSS.replicate (n - l) 0 -normStaticBytes :: KnownNat n => StaticBytes n -> StaticBytes n +normStaticBytes :: (KnownNat n) => StaticBytes n -> StaticBytes n normStaticBytes sb@(StaticBytes sbs) = mkStaticBytes (proxyForNatF sb) sbs -instance KnownNat n => Eq (StaticBytes n) where +instance (KnownNat n) => Eq (StaticBytes n) where x == y = let StaticBytes x' = normStaticBytes x StaticBytes y' = normStaticBytes y in x' == y' -instance KnownNat n => Ord (StaticBytes n) where +instance (KnownNat n) => Ord (StaticBytes n) where compare x y = let StaticBytes x' = normStaticBytes x StaticBytes y' = normStaticBytes y @@ -121,25 +143,26 @@ instance Default (StaticBytes n) where def = StaticBytes BSS.empty -instance KnownNat n => StaticByteSized (StaticBytes n) where - staticByteSize _ = fromInteger (natVal (Proxy :: Proxy n)) +instance (KnownNat n) => StaticByteSized (StaticBytes n) where + type StaticSize (StaticBytes n) = n -instance KnownNat n => Binary (StaticBytes n) where +instance (KnownNat n) => Binary (StaticBytes n) where + byteSize = byteSizeViaStatic 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} deriving stock (Show) deriving newtype (Eq, Functor, Foldable) - deriving (ByteSized) via (ViaStaticByteSized (StaticSeq n a)) instance (KnownNat n, Default a) => Default (StaticSeq n a) where def = StaticSeq (Seq.replicate (fromInteger (natVal (Proxy :: Proxy n))) def) instance (KnownNat n, StaticByteSized a) => StaticByteSized (StaticSeq n a) where - staticByteSize _ = fromInteger (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a) + type StaticSize (StaticSeq n a) = n * StaticSize a instance (KnownNat n, Binary a, StaticByteSized a, Default a) => Binary (StaticSeq n a) where + byteSize = byteSizeViaStatic get = fmap StaticSeq (getStaticSeq (fromInteger (natVal (Proxy :: Proxy n))) get) put = unsafePutStaticSeqN (fromInteger (natVal (Proxy :: Proxy n))) (Just def) put . unStaticSeq @@ -147,45 +170,51 @@ deriving stock (Show) deriving newtype (Eq) -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 _ = fromInteger (natVal (Proxy :: Proxy n)) * staticByteSize (Proxy :: Proxy a) + type StaticSize (StaticArray n a) = n * StaticSize a instance (KnownNat n, LiftedPrim a, Default a) => Binary (StaticArray n a) where + byteSize = byteSizeViaStatic 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) deriving newtype (Eq) - deriving (ByteSized) via (ViaStaticByteSized BoolByte) instance Default BoolByte where def = BoolByte False instance StaticByteSized BoolByte where + type StaticSize BoolByte = 1 staticByteSize _ = 1 instance Binary BoolByte where + byteSize = byteSizeViaStatic get = fmap (BoolByte . (/= 0)) getWord8 put (BoolByte b) = putWord8 (if b then 1 else 0) -newtype ExactBytes (s :: Symbol) = ExactBytes {unExactBytes :: ()} +newtype ExactBytes (n :: Nat) (s :: Symbol) = ExactBytes {unExactBytes :: ()} deriving stock (Show) deriving newtype (Eq) - deriving (ByteSized) via (ViaStaticByteSized (ExactBytes s)) -instance Default (ExactBytes s) where +instance Default (ExactBytes n s) where def = ExactBytes () -instance KnownSymbol s => StaticByteSized (ExactBytes s) where - staticByteSize _ = coerce (length (symbolVal (Proxy :: Proxy s))) +class SymLen (n :: Nat) (s :: Symbol) | s -> n -instance KnownSymbol s => Binary (ExactBytes s) where +instance {-# OVERLAPPING #-} SymLen 0 "" + +instance (SymLen n s, m ~ n + 1, t ~ ConsSymbol c s) => SymLen m t + +instance (SymLen n s, KnownSymbol s, KnownNat n) => StaticByteSized (ExactBytes n s) where + type StaticSize (ExactBytes n s) = n + +instance (SymLen n s, KnownSymbol s, KnownNat n) => Binary (ExactBytes n s) where + byteSize = byteSizeViaStatic get = do let s = symbolVal (Proxy :: Proxy s) bc = coerce (length s) diff --git a/src/Dahdit/Free.hs b/src/Dahdit/Free.hs --- a/src/Dahdit/Free.hs +++ b/src/Dahdit/Free.hs @@ -46,16 +46,18 @@ import Data.Primitive (ByteArray) import Data.Proxy (Proxy (..)) import Data.Sequence (Seq) +import Data.Text (Text) +import qualified Data.Text as T import Data.Word (Word8) data GetStaticSeqF a where - GetStaticSeqF :: StaticByteSized z => !ElemCount -> 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 :: LiftedPrim z => !ElemCount -> Proxy z -> (LiftedPrimArray 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) @@ -108,23 +110,23 @@ | GetFSkip !ByteCount a | GetFLookAhead !(GetLookAheadF a) | GetFRemainingSize (ByteCount -> a) - | GetFFail !String + | GetFFail !Text deriving stock (Functor) newtype Get a = Get {unGet :: F GetF a} deriving newtype (Functor, Applicative, Monad) instance MonadFail Get where - fail msg = Get (F (\_ y -> y (GetFFail msg))) + fail msg = Get (F (\_ y -> y (GetFFail (T.pack msg)))) data PutStaticSeqF a where - PutStaticSeqF :: StaticByteSized z => !ElemCount -> !(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 :: LiftedPrim z => !ElemCount -> !(Maybe z) -> !(LiftedPrimArray 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) diff --git a/src/Dahdit/Funs.hs b/src/Dahdit/Funs.hs --- a/src/Dahdit/Funs.hs +++ b/src/Dahdit/Funs.hs @@ -21,6 +21,7 @@ , getInt64BE , getFloatBE , getDoubleBE + , getText , getByteString , getSkip , getExact @@ -63,6 +64,7 @@ , putInt64BE , putFloatBE , putDoubleBE + , putText , putByteString , putFixedString , putList @@ -77,7 +79,7 @@ ) where -import Control.Monad (replicateM_, unless) +import Control.Monad (replicateM_, unless, (>=>)) import Control.Monad.Free.Church (F (..)) import Dahdit.Free ( Get (..) @@ -130,6 +132,8 @@ import Data.Proxy (Proxy (..)) import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Data.Word (Word8) getWord8 :: Get Word8 @@ -198,6 +202,9 @@ getDoubleBE :: Get DoubleBE getDoubleBE = Get (F (\x y -> y (GetFDoubleBE x))) +getText :: ByteCount -> Get Text +getText = getByteString >=> either (fail . ("Invalid UTF-8: " ++) . show) pure . TE.decodeUtf8' . BSS.fromShort + getByteString :: ByteCount -> Get ShortByteString getByteString bc = Get (F (\x y -> y (GetFShortByteString bc x))) @@ -233,17 +240,17 @@ go (acc :|> x) (i + 1) -- | Get Seq of statically-sized elements -getStaticSeq :: StaticByteSized a => ElemCount -> 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 :: LiftedPrim a => ElemCount -> Get (LiftedPrimArray 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 -> ElemCount -> Get (LiftedPrimArray a) +getLiftedPrimArray :: (LiftedPrim a) => Proxy a -> ElemCount -> Get (LiftedPrimArray a) getLiftedPrimArray prox ec = let bc = staticByteSize prox * coerce ec in fmap LiftedPrimArray (getByteArray bc) @@ -268,7 +275,7 @@ x <- g 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) bc <- getRemainingSize @@ -277,7 +284,7 @@ then getStaticSeq (coerce (div bc ebc)) g else fail ("Leftover bytes for remaining static seq (have " ++ show (unByteCount left) ++ ", need " ++ show (unByteCount ebc) ++ ")") -getRemainingStaticArray :: LiftedPrim a => Proxy a -> Get (LiftedPrimArray a) +getRemainingStaticArray :: (LiftedPrim a) => Proxy a -> Get (LiftedPrimArray a) getRemainingStaticArray prox = do let ebc = staticByteSize prox bc <- getRemainingSize @@ -289,7 +296,7 @@ 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 = staticByteSize prox bc <- getRemainingSize @@ -380,6 +387,9 @@ putDoubleBE :: DoubleBE -> Put putDoubleBE d = PutM (F (\x y -> y (PutFDoubleBE d (x ())))) +putText :: Text -> Put +putText = putByteString . BSS.toShort . TE.encodeUtf8 + putByteString :: ShortByteString -> Put putByteString sbs = let bc = coerce (BSS.length sbs) @@ -405,21 +415,21 @@ putSeq = traverse_ -- | Put Seq of statically-sized elements -putStaticSeq :: StaticByteSized a => (a -> Put) -> Seq a -> Put +putStaticSeq :: (StaticByteSized a) => (a -> Put) -> Seq a -> Put putStaticSeq p s = let n = coerce (Seq.length s) in unsafePutStaticSeqN n Nothing p s -unsafePutStaticSeqN :: StaticByteSized a => ElemCount -> 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 :: LiftedPrim a => LiftedPrimArray a -> Put +putStaticArray :: (LiftedPrim a) => LiftedPrimArray a -> Put putStaticArray a = let ec = lengthLiftedPrimArray a in unsafePutStaticArrayN ec Nothing a -unsafePutStaticArrayN :: LiftedPrim a => ElemCount -> Maybe a -> LiftedPrimArray 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 @@ -430,7 +440,7 @@ putLiftedPrimArray :: LiftedPrimArray a -> Put putLiftedPrimArray = putByteArray . unLiftedPrimArray -putStaticHint :: StaticByteSized a => (a -> Put) -> a -> Put +putStaticHint :: (StaticByteSized a) => (a -> Put) -> a -> Put putStaticHint p a = let bc = staticByteSize (proxyForFun p) in PutM (F (\x y -> y (PutFStaticHint (PutStaticHintF bc (p a) (x ()))))) diff --git a/src/Dahdit/Generic.hs b/src/Dahdit/Generic.hs --- a/src/Dahdit/Generic.hs +++ b/src/Dahdit/Generic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} module Dahdit.Generic ( ViaGeneric (..) @@ -11,19 +12,35 @@ import Dahdit.Free (Get, Put) import Dahdit.Funs (putStaticHint) import Dahdit.Nums (Word16LE, Word32LE) -import Dahdit.Sizes (ByteCount, ByteSized (..), StaticByteSized (..)) +import Dahdit.Proxy (proxyForRepF) +import Dahdit.Sizes (ByteCount, StaticByteSized (..)) import Data.Bits (Bits (..)) import Data.Kind (Type) import Data.Proxy (Proxy (..)) import Data.Word (Word8) import GHC.Generics (C1, Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..), (:+:) (..)) +import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) --- | Use: deriving (ByteSized, Binary) via (ViaGeneric Foo) +-- | Use: deriving (Binary) via (ViaGeneric Foo) newtype ViaGeneric a = ViaGeneric {unViaGeneric :: a} --- | Use: deriving (ByteSized, StaticByteSized, Binary) via (ViaStaticGeneric Foo) +instance (Generic t, GByteSized (Rep t), GBinary (Rep t)) => Binary (ViaGeneric t) where + byteSize = gbyteSize . from . unViaGeneric + get = fmap (ViaGeneric . to) gget + put = gput . from . unViaGeneric + +-- | Use: deriving (StaticByteSized, Binary) via (ViaStaticGeneric Foo) newtype ViaStaticGeneric a = ViaStaticGeneric {unViaStaticGeneric :: a} +instance (Generic t, GStaticByteSized (Rep t), GBinary (Rep t)) => Binary (ViaStaticGeneric t) where + byteSize sg = gstaticByteSize (proxyForRepF sg (from (unViaStaticGeneric sg))) + get = fmap (ViaStaticGeneric . to) gget + put = putStaticHint (gput . from . unViaStaticGeneric) + +instance (GStaticByteSized (Rep t)) => StaticByteSized (ViaStaticGeneric t) where + type StaticSize (ViaStaticGeneric t) = GStaticSize (Rep t) + staticByteSize _ = gstaticByteSize (Proxy :: Proxy (Rep t)) + -- ByteSized: class GByteSized f where @@ -34,11 +51,11 @@ gbyteSize _ = 0 -- Product -instance (GByteSized a, GByteSized b) => GByteSized (a :*: b) where +instance (GByteSized a, GByteSized b, o ~ n + m) => GByteSized (a :*: b) where gbyteSize (x :*: y) = gbyteSize x + gbyteSize y -- Metadata -instance GByteSized a => GByteSized (M1 i c a) where +instance (GByteSized a) => GByteSized (M1 i c a) where gbyteSize = gbyteSize . unM1 -- Sum @@ -49,34 +66,35 @@ R1 b -> gbyteSize b -- Field -instance ByteSized a => GByteSized (K1 i a) where +instance (Binary a) => GByteSized (K1 i a) where gbyteSize = byteSize . unK1 -instance (Generic t, GByteSized (Rep t)) => ByteSized (ViaGeneric t) where - byteSize = gbyteSize . from . unViaGeneric - -instance (Generic t, GByteSized (Rep t)) => ByteSized (ViaStaticGeneric t) where - byteSize = gbyteSize . from . unViaStaticGeneric - -- StaticByteSized: -class GByteSized f => GStaticByteSized (f :: Type -> Type) where +class (KnownNat (GStaticSize f)) => GStaticByteSized (f :: Type -> Type) where + type GStaticSize f :: Nat gstaticByteSize :: Proxy f -> ByteCount + gstaticByteSize = fromInteger . natVal . gstaticByteProxy +gstaticByteProxy :: Proxy f -> Proxy (GStaticSize f) +gstaticByteProxy _ = Proxy + instance GStaticByteSized U1 where - gstaticByteSize _ = 0 + type GStaticSize U1 = 0 instance (GStaticByteSized a, GStaticByteSized b) => GStaticByteSized (a :*: b) where - gstaticByteSize _ = gstaticByteSize (Proxy :: Proxy a) + gstaticByteSize (Proxy :: Proxy b) + type GStaticSize (a :*: b) = GStaticSize a + GStaticSize b -instance GStaticByteSized a => GStaticByteSized (M1 i c a) where - gstaticByteSize _ = gstaticByteSize (Proxy :: Proxy a) +instance (GStaticByteSized a) => GStaticByteSized (M1 i c a) where + type GStaticSize (M1 i c a) = GStaticSize a -instance StaticByteSized a => GStaticByteSized (K1 i a) where - gstaticByteSize _ = staticByteSize (Proxy :: Proxy a) +-- GHC BUG: KnownNat is not actually redundant +instance (StaticByteSized a) => GStaticByteSized (K1 i a) where + type GStaticSize (K1 i a) = StaticSize a -instance (Generic t, GStaticByteSized (Rep t)) => StaticByteSized (ViaStaticGeneric t) where - staticByteSize _ = gstaticByteSize (Proxy :: Proxy (Rep t)) +-- This one line is the reason all the nat constraints are threaded through this codebase +instance (GStaticByteSized a, GStaticByteSized b, GStaticSize a ~ GStaticSize b) => GStaticByteSized (a :+: b) where + type GStaticSize (a :+: b) = GStaticSize a -- Binary: @@ -92,22 +110,14 @@ gget = liftA2 (:*:) gget gget gput (x :*: y) = gput x *> gput y -instance GBinary a => GBinary (M1 i c a) where +instance (GBinary a) => GBinary (M1 i c a) where gget = fmap M1 gget gput = gput . unM1 -instance Binary a => GBinary (K1 i a) where +instance (Binary a) => GBinary (K1 i a) where gget = fmap K1 get gput = put . unK1 -instance (Generic t, GBinary (Rep t)) => Binary (ViaGeneric t) where - get = fmap (ViaGeneric . to) gget - put = gput . from . unViaGeneric - -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! @@ -141,7 +151,7 @@ where size = unTagged (sumSize :: Tagged (a :+: b)) -sizeError :: Show size => String -> size -> error +sizeError :: (Show size) => String -> size -> error sizeError s size = error ("Can't " ++ s ++ " a type with " ++ show size ++ " constructors") checkGetSum @@ -172,7 +182,7 @@ sizeL = size `shiftR` 1 sizeR = size - sizeL -instance GBinary a => GSumBinary (C1 c a) where +instance (GBinary a) => GSumBinary (C1 c a) where getSum _ _ = gget putSum !code _ x = put code <> gput x @@ -187,7 +197,7 @@ instance SumSize (C1 c a) where sumSize = Tagged 1 -sumSizeFor :: SumSize f => f a -> Tagged f +sumSizeFor :: (SumSize f) => f a -> Tagged f sumSizeFor = const sumSize taggedBytes :: Tagged f -> ByteCount @@ -197,5 +207,5 @@ | size - 1 <= (maxBound :: Word32LE) = 4 | otherwise = sizeError "size" size -sumSizeBytes :: SumSize f => f a -> ByteCount +sumSizeBytes :: (SumSize f) => f a -> ByteCount sumSizeBytes = taggedBytes . sumSizeFor diff --git a/src/Dahdit/Iface.hs b/src/Dahdit/Iface.hs --- a/src/Dahdit/Iface.hs +++ b/src/Dahdit/Iface.hs @@ -1,141 +1,252 @@ module Dahdit.Iface - ( BinaryTarget (..) + ( BinaryGetTarget (..) , getTarget + , BinaryPutTarget (..) , putTarget - , MutBinaryTarget (..) + , MutBinaryPutTarget (..) , mutPutTargetOffset , mutPutTarget + , getEnd , decode + , decodeInc + , decodeEnd , decodeFile + , decodeFileEnd , encode , encodeFile , mutEncode ) where -import Control.Monad.Primitive (PrimBase, PrimMonad (..)) -import Control.Monad.ST (runST) +import Control.Monad (unless, (>=>)) +import Control.Monad.Primitive (MonadPrim, PrimMonad (..), RealWorld) import Dahdit.Binary (Binary (..)) import Dahdit.Free (Get, Put) -import Dahdit.Mem (allocBAMem, allocPtrMem, freezeBAMem, freezeBSMem, freezeSBSMem, freezeVecMem, mutAllocBAMem, mutAllocVecMem, mutFreezeBAMem, mutFreezeVecMem, viewBSMem, viewSBSMem, viewVecMem) -import Dahdit.Run (GetError, runCount, runGetInternal, runPutInternal) -import Dahdit.Sizes (ByteCount (..), ByteSized (..)) +import Dahdit.Funs (getRemainingSize) +import Dahdit.Mem (MemPtr (..), MutableMem (..), emptyMemPtr, mutViewVecMem, viewBSMem, viewSBSMem, viewVecMem, withBAMem, withBSMem, withSBSMem, withVecMem) +import Dahdit.Run (GetError, GetIncCb, GetIncChunk (..), newGetIncEnv, runCount, runGetIncInternal, runGetInternal, runPutInternal) +import Dahdit.Sizes (ByteCount (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS import Data.Coerce (coerce) -import Data.Primitive.ByteArray (ByteArray, MutableByteArray, sizeofByteArray) +import Data.Primitive.ByteArray (ByteArray, MutableByteArray, emptyByteArray, sizeofByteArray) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as VS -import Data.Vector.Storable.Mutable (MVector) +import Data.Vector.Storable.Mutable (IOVector) 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 length. - -- Prefer 'putTarget' to safely count capacity, or use 'encode' to use byte size. - putTargetUnsafe :: Put -> ByteCount -> z - +-- | Abstracts over the sources we can read from. +class (PrimMonad m) => BinaryGetTarget z m where -- | 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) + getTargetOffset :: ByteCount -> Get a -> z -> m (Either GetError a, ByteCount) + -- | Get a value incrementally from sources yielded by the given callback, returning a + -- result, final offset in the whole stream, and final offset in the current chunk. + -- Takes an optional maximum capacity. + getTargetInc :: Maybe ByteCount -> Get a -> GetIncCb z m -> m (Either GetError a, ByteCount, ByteCount) + -- | Get a value from the source, returning a result and final offset. -getTarget :: BinaryTarget z => Get a -> z -> (Either GetError a, ByteCount) +getTarget :: (BinaryGetTarget z m) => Get a -> z -> m (Either GetError a, ByteCount) getTarget = getTargetOffset 0 +-- | Abstracts over the immutable sinks we can render to. +class (BinaryGetTarget z m) => BinaryPutTarget z m where + -- | Put an action to the sink with the given length. + -- Prefer 'putTarget' to safely count capacity, or use 'encode' to use byte size. + putTargetUnsafe :: Put -> ByteCount -> m z + -- | Put an action to the sink with calculated capacity. -putTarget :: BinaryTarget z => Put -> z +putTarget :: (BinaryPutTarget z m) => Put -> m z putTarget p = putTargetUnsafe p (runCount p) -class MutBinaryTarget m z where +class (BinaryGetTarget z m) => MutBinaryPutTarget z m where mutPutTargetOffsetUnsafe :: ByteCount -> Put -> ByteCount -> z -> m ByteCount -mutPutTargetOffset :: MutBinaryTarget m z => ByteCount -> Put -> z -> m ByteCount +mutPutTargetOffset :: (MutBinaryPutTarget z m) => ByteCount -> Put -> z -> m ByteCount mutPutTargetOffset off p = mutPutTargetOffsetUnsafe off p (runCount p) -mutPutTarget :: MutBinaryTarget m z => Put -> z -> m ByteCount +mutPutTarget :: (MutBinaryPutTarget z m) => Put -> z -> m ByteCount mutPutTarget = mutPutTargetOffset 0 -instance BinaryTarget ShortByteString where +instance BinaryGetTarget String IO where + getTargetOffset = runGetString + getTargetInc = runGetIncString + +instance BinaryPutTarget String IO where + putTargetUnsafe = runPutString + +instance BinaryGetTarget Text IO where + getTargetOffset = runGetText + getTargetInc = runGetIncText + +instance BinaryPutTarget Text IO where + putTargetUnsafe = runPutText + +instance (PrimMonad m) => BinaryGetTarget ShortByteString m where getTargetOffset = runGetSBS + getTargetInc = runGetIncSBS + +instance (PrimMonad m) => BinaryPutTarget ShortByteString m where putTargetUnsafe = runPutSBS -instance BinaryTarget ByteString where +instance BinaryGetTarget ByteString IO where getTargetOffset = runGetBS + getTargetInc = runGetIncBS + +instance BinaryPutTarget ByteString IO where putTargetUnsafe = runPutBS -instance BinaryTarget ByteArray where +instance (PrimMonad m) => BinaryGetTarget ByteArray m where getTargetOffset = runGetBA + getTargetInc = runGetIncBA + +instance (PrimMonad m) => BinaryPutTarget ByteArray m where putTargetUnsafe = runPutBA -instance BinaryTarget (Vector Word8) where +instance BinaryGetTarget (Vector Word8) IO where getTargetOffset = runGetVec + getTargetInc = runGetIncVec + +instance BinaryPutTarget (Vector Word8) IO where putTargetUnsafe = runPutVec -instance (PrimBase m, s ~ PrimState m) => MutBinaryTarget m (MutableByteArray s) where +instance (MonadPrim s m) => BinaryGetTarget (MutableByteArray s) m where + getTargetOffset bc g z = unsafeUseFrozenMem z (getTargetOffset bc g) + getTargetInc mbc g cb = getTargetInc mbc g (cb >=> maybe (pure Nothing) (fmap Just . unsafeFreezeMem)) + +instance (MonadPrim s m) => MutBinaryPutTarget (MutableByteArray s) m where mutPutTargetOffsetUnsafe = runMutPutBA -instance (PrimBase m, s ~ PrimState m) => MutBinaryTarget m (MVector s Word8) where +instance BinaryGetTarget (IOVector Word8) IO where + getTargetOffset bc g z = unsafeUseFrozenMem z (getTargetOffset bc g) + getTargetInc mbc g cb = getTargetInc mbc g (cb >=> maybe (pure Nothing) (fmap Just . unsafeFreezeMem)) + +instance MutBinaryPutTarget (IOVector Word8) IO where mutPutTargetOffsetUnsafe = runMutPutVec +-- | Wrapper that asserts a get action has consumed to the end. +getEnd :: Get a -> Get a +getEnd getter = do + a <- getter + b <- getRemainingSize + unless (b == 0) (fail ("Expected end of input but had bytes remaining: " ++ show (unByteCount b))) + pure a + -- | Decode a value from a source returning a result and consumed byte count. -decode :: (Binary a, BinaryTarget z) => z -> (Either GetError a, ByteCount) +decode :: (Binary a, BinaryGetTarget z m) => z -> m (Either GetError a, ByteCount) decode = getTarget get +-- | Decode a value incrementally from sources yielded by a callback. +decodeInc :: (Binary a, BinaryGetTarget z m) => Maybe ByteCount -> GetIncCb z m -> m (Either GetError a, ByteCount, ByteCount) +decodeInc mayCap = getTargetInc mayCap get + +-- | 'decode' but expect the end of input. +decodeEnd :: (Binary a, BinaryGetTarget z m) => z -> m (Either GetError a, ByteCount) +decodeEnd = getTarget (getEnd get) + -- | Decode a value from a file. -decodeFile :: Binary a => FilePath -> IO (Either GetError a, ByteCount) +decodeFile :: (Binary a) => FilePath -> IO (Either GetError a, ByteCount) decodeFile = runGetFile get +-- | 'decodeFile' but expect the end of file. +decodeFileEnd :: (Binary a) => FilePath -> IO (Either GetError a, ByteCount) +decodeFileEnd = runGetFile (getEnd get) + -- | Encode a value to a sink. -encode :: (Binary a, ByteSized a, BinaryTarget z) => a -> z +encode :: (Binary a, BinaryPutTarget z m) => a -> m z encode a = putTargetUnsafe (put a) (byteSize a) -- | Encode a value to a file. -encodeFile :: (Binary a, ByteSized a) => a -> FilePath -> IO () +encodeFile :: (Binary a) => a -> FilePath -> IO () encodeFile a = runPutFile (put a) (byteSize a) -- | Encode a value to a mutable buffer, returning number of bytes filled. -mutEncode :: (Binary a, ByteSized a, MutBinaryTarget m z) => a -> z -> m ByteCount +mutEncode :: (Binary a, MutBinaryPutTarget z m) => a -> z -> m ByteCount mutEncode a = mutPutTargetOffsetUnsafe 0 (put a) (byteSize a) -runGetBA :: ByteCount -> Get a -> ByteArray -> (Either GetError a, ByteCount) +runGetString :: ByteCount -> Get a -> String -> IO (Either GetError a, ByteCount) +runGetString off act = runGetBS off act . BSC.pack + +runGetText :: ByteCount -> Get a -> Text -> IO (Either GetError a, ByteCount) +runGetText off act = runGetBS off act . TE.encodeUtf8 + +runGetBA :: (PrimMonad m) => ByteCount -> Get a -> ByteArray -> m (Either GetError a, ByteCount) runGetBA off act ba = runGetInternal off act (coerce (sizeofByteArray ba)) ba -runGetSBS :: ByteCount -> Get a -> ShortByteString -> (Either GetError a, ByteCount) -runGetSBS off act sbs = runGetInternal off act (coerce (BSS.length sbs)) (viewSBSMem sbs) +runGetSBS :: (PrimMonad m) => ByteCount -> Get a -> ShortByteString -> m (Either GetError a, ByteCount) +runGetSBS off act = runGetBA off act . viewSBSMem -runGetBS :: ByteCount -> Get a -> ByteString -> (Either GetError a, ByteCount) +runGetBS :: ByteCount -> Get a -> ByteString -> IO (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 :: ByteCount -> Get a -> Vector Word8 -> IO (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) + runGetBS 0 act bs -runPutBA :: Put -> ByteCount -> ByteArray -runPutBA act len = runST (runPutInternal 0 act len allocBAMem freezeBAMem) +runGetIncString :: Maybe ByteCount -> Get a -> GetIncCb String IO -> IO (Either GetError a, ByteCount, ByteCount) +runGetIncString mayCap g cb = runGetIncBS mayCap g (fmap (fmap BSC.pack) . cb) -runPutSBS :: Put -> ByteCount -> ShortByteString -runPutSBS act len = runST (runPutInternal 0 act len allocBAMem freezeSBSMem) +runGetIncText :: Maybe ByteCount -> Get a -> GetIncCb Text IO -> IO (Either GetError a, ByteCount, ByteCount) +runGetIncText mayCap g cb = runGetIncBS mayCap g (fmap (fmap TE.encodeUtf8) . cb) -runPutBS :: Put -> ByteCount -> ByteString -runPutBS act len = runST (runPutInternal 0 act len allocPtrMem freezeBSMem) +runGetIncBA :: (PrimMonad m) => Maybe ByteCount -> Get a -> GetIncCb ByteArray m -> m (Either GetError a, ByteCount, ByteCount) +runGetIncBA mayCap act cb = do + env <- newGetIncEnv mayCap (GetIncChunk 0 0 emptyByteArray) + let view s = GetIncChunk 0 (coerce (sizeofByteArray s)) s + let cb' = fmap (fmap view) . cb + runGetIncInternal act env cb' -runPutVec :: Put -> ByteCount -> Vector Word8 -runPutVec act len = runST (runPutInternal 0 act len allocPtrMem freezeVecMem) +runGetIncSBS :: (PrimMonad m) => Maybe ByteCount -> Get a -> GetIncCb ShortByteString m -> m (Either GetError a, ByteCount, ByteCount) +runGetIncSBS mayCap act cb = runGetIncBA mayCap act (fmap (fmap viewSBSMem) . cb) +runGetIncMemPtr :: Maybe ByteCount -> Get a -> GetIncCb (MemPtr RealWorld) IO -> IO (Either GetError a, ByteCount, ByteCount) +runGetIncMemPtr mayCap act cb = do + mem <- emptyMemPtr + env <- newGetIncEnv mayCap (GetIncChunk 0 0 mem) + let view mem'@(MemPtr _ off len) = GetIncChunk 0 (len - off) mem' + let cb' = fmap (fmap view) . cb + runGetIncInternal act env cb' + +runGetIncBS :: Maybe ByteCount -> Get a -> GetIncCb ByteString IO -> IO (Either GetError a, ByteCount, ByteCount) +runGetIncBS mayCap act cb = runGetIncMemPtr mayCap act (fmap (fmap viewBSMem) . cb) + +runGetIncVec :: Maybe ByteCount -> Get a -> GetIncCb (Vector Word8) IO -> IO (Either GetError a, ByteCount, ByteCount) +runGetIncVec mayCap act cb = runGetIncMemPtr mayCap act (fmap (fmap viewVecMem) . cb) + +runPutString :: Put -> ByteCount -> IO String +runPutString act len = fmap BSC.unpack (runPutBS act len) + +runPutText :: Put -> ByteCount -> IO Text +runPutText act len = fmap TE.decodeUtf8 (runPutBS act len) + +runPutBA :: (PrimMonad m) => Put -> ByteCount -> m ByteArray +runPutBA act len = withBAMem len (runPutInternal 0 act len) + +runPutSBS :: (PrimMonad m) => Put -> ByteCount -> m ShortByteString +runPutSBS act len = withSBSMem len (runPutInternal 0 act len) + +runPutBS :: Put -> ByteCount -> IO ByteString +runPutBS act len = withBSMem len (runPutInternal 0 act len) + +runPutVec :: Put -> ByteCount -> IO (Vector Word8) +runPutVec act len = withVecMem len (runPutInternal 0 act len) + runPutFile :: Put -> ByteCount -> FilePath -> IO () -runPutFile act cap fp = - let bs = runPutBS act cap - in BS.writeFile fp bs +runPutFile act cap fp = do + bs <- runPutBS act cap + BS.writeFile fp bs -runMutPutBA :: PrimBase m => ByteCount -> Put -> ByteCount -> MutableByteArray (PrimState m) -> m ByteCount -runMutPutBA off act len marr = runPutInternal off act len (mutAllocBAMem marr) mutFreezeBAMem +runMutPutBA :: (MonadPrim s m) => ByteCount -> Put -> ByteCount -> MutableByteArray s -> m ByteCount +runMutPutBA = runPutInternal -runMutPutVec :: PrimBase m => ByteCount -> Put -> ByteCount -> MVector (PrimState m) Word8 -> m ByteCount -runMutPutVec off act len mvec = runPutInternal off act len (mutAllocVecMem mvec) mutFreezeVecMem +runMutPutVec :: ByteCount -> Put -> ByteCount -> IOVector Word8 -> IO ByteCount +runMutPutVec off act len mvec = runPutInternal off act len (mutViewVecMem mvec) diff --git a/src/Dahdit/Internal.hs b/src/Dahdit/Internal.hs --- a/src/Dahdit/Internal.hs +++ b/src/Dahdit/Internal.hs @@ -5,15 +5,16 @@ import Data.ShortWord (Int24, Word24) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Float (castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble) +import GHC.TypeLits (Nat) -newtype ViaFromIntegral x y = ViaFromIntegral {unViaFromIntegral :: y} +newtype ViaFromIntegral (n :: Nat) x y = ViaFromIntegral {unViaFromIntegral :: y} deriving newtype (Num) -- Types that can swap endianness - swapEndian is its own inverse -class Num w => SwapEndian w where +class (Num w) => SwapEndian w where swapEndian :: w -> w -instance (SwapEndian x, Integral x, Integral y) => SwapEndian (ViaFromIntegral x y) where +instance (SwapEndian x, Integral x, Integral y) => SwapEndian (ViaFromIntegral n x y) where swapEndian = ViaFromIntegral . fromIntegral @x @y . swapEndian . fromIntegral @y @x . unViaFromIntegral instance SwapEndian Word8 where @@ -27,28 +28,28 @@ let (!b0, !b1) = unMkWord16LE w in mkWord16LE b1 b0 -deriving via (ViaFromIntegral Word16 Int16) instance SwapEndian Int16 +deriving via (ViaFromIntegral n Word16 Int16) instance SwapEndian Int16 instance SwapEndian Word24 where swapEndian w = let (!b0, !b1, !b2) = unMkWord24LE w in mkWord24LE b2 b1 b0 -deriving via (ViaFromIntegral Word24 Int24) instance SwapEndian Int24 +deriving via (ViaFromIntegral n Word24 Int24) instance SwapEndian Int24 instance SwapEndian Word32 where swapEndian w = let (!b0, !b1, !b2, !b3) = unMkWord32LE w in mkWord32LE b3 b2 b1 b0 -deriving via (ViaFromIntegral Word32 Int32) instance SwapEndian Int32 +deriving via (ViaFromIntegral n 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 +deriving via (ViaFromIntegral n Word64 Int64) instance SwapEndian Int64 instance SwapEndian Float where swapEndian w = @@ -128,16 +129,16 @@ 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 +class (Num le, Num be) => EndianPair (n :: Nat) le be | le -> n, be -> n, le -> be, be -> le where toLittleEndian :: be -> le toBigEndian :: le -> be -newtype ViaEndianPair le be = ViaEndianPair {unViaEndianPair :: be} +newtype ViaEndianPair (n :: Nat) le be = ViaEndianPair {unViaEndianPair :: be} -instance EndianPair Word8 Word8 where +instance EndianPair 1 Word8 Word8 where toLittleEndian = id toBigEndian = id -instance EndianPair Int8 Int8 where +instance EndianPair 1 Int8 Int8 where toLittleEndian = id toBigEndian = id diff --git a/src/Dahdit/LiftedPrim.hs b/src/Dahdit/LiftedPrim.hs --- a/src/Dahdit/LiftedPrim.hs +++ b/src/Dahdit/LiftedPrim.hs @@ -52,13 +52,13 @@ -- | 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 lifted byte arrays and pointers. -class StaticByteSized a => LiftedPrim a where +class (StaticByteSized a) => LiftedPrim a where indexArrayLiftedInBytes :: ByteArray -> ByteCount -> a - writeArrayLiftedInBytes :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> a -> m () + writeArrayLiftedInBytes :: (PrimMonad m) => MutableByteArray (PrimState m) -> ByteCount -> a -> m () indexPtrLiftedInBytes :: Ptr Word8 -> ByteCount -> a - writePtrLiftedInBytes :: PrimMonad m => Ptr Word8 -> ByteCount -> a -> m () + writePtrLiftedInBytes :: (PrimMonad m) => Ptr Word8 -> ByteCount -> a -> m () -indexArrayLiftedInElems :: LiftedPrim a => Proxy a -> ByteArray -> ElemCount -> a +indexArrayLiftedInElems :: (LiftedPrim a) => Proxy a -> ByteArray -> ElemCount -> a indexArrayLiftedInElems prox arr pos = indexArrayLiftedInBytes arr (coerce pos * staticByteSize prox) @@ -66,7 +66,7 @@ writeArrayLiftedInElems arr pos val = writeArrayLiftedInBytes arr (coerce pos * staticByteSize (proxyFor val)) val -indexPtrLiftedInElems :: LiftedPrim a => Proxy a -> Ptr Word8 -> ElemCount -> a +indexPtrLiftedInElems :: (LiftedPrim a) => Proxy a -> Ptr Word8 -> ElemCount -> a indexPtrLiftedInElems prox ptr pos = indexPtrLiftedInBytes ptr (coerce pos * staticByteSize prox) @@ -87,7 +87,7 @@ 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 +instance (Integral x, LiftedPrim x, Integral y, n ~ StaticSize x) => LiftedPrim (ViaFromIntegral n x y) where 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 @@ -287,39 +287,39 @@ *> writeOffPtr ptr (coerce off + 6) b6 *> writeOffPtr ptr (coerce off + 7) b7 -instance (LiftedPrim le, EndianPair le be) => LiftedPrim (ViaEndianPair le be) where +instance (LiftedPrim le, EndianPair n le be, n ~ StaticSize le) => LiftedPrim (ViaEndianPair n 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 2 Word16LE Int16LE) instance LiftedPrim Int16LE -deriving via (ViaFromIntegral Word24LE Int24LE) instance LiftedPrim Int24LE +deriving via (ViaFromIntegral 3 Word24LE Int24LE) instance LiftedPrim Int24LE -deriving via (ViaFromIntegral Word32LE Int32LE) instance LiftedPrim Int32LE +deriving via (ViaFromIntegral 4 Word32LE Int32LE) instance LiftedPrim Int32LE -deriving via (ViaFromIntegral Word64LE Int64LE) instance LiftedPrim Int64LE +deriving via (ViaFromIntegral 8 Word64LE Int64LE) instance LiftedPrim Int64LE -deriving via (ViaEndianPair Word16LE Word16BE) instance LiftedPrim Word16BE +deriving via (ViaEndianPair 2 Word16LE Word16BE) instance LiftedPrim Word16BE -deriving via (ViaEndianPair Int16LE Int16BE) instance LiftedPrim Int16BE +deriving via (ViaEndianPair 2 Int16LE Int16BE) instance LiftedPrim Int16BE -deriving via (ViaEndianPair Word24LE Word24BE) instance LiftedPrim Word24BE +deriving via (ViaEndianPair 3 Word24LE Word24BE) instance LiftedPrim Word24BE -deriving via (ViaEndianPair Int24LE Int24BE) instance LiftedPrim Int24BE +deriving via (ViaEndianPair 3 Int24LE Int24BE) instance LiftedPrim Int24BE -deriving via (ViaEndianPair Word32LE Word32BE) instance LiftedPrim Word32BE +deriving via (ViaEndianPair 4 Word32LE Word32BE) instance LiftedPrim Word32BE -deriving via (ViaEndianPair Int32LE Int32BE) instance LiftedPrim Int32BE +deriving via (ViaEndianPair 4 Int32LE Int32BE) instance LiftedPrim Int32BE -deriving via (ViaEndianPair Word64LE Word64BE) instance LiftedPrim Word64BE +deriving via (ViaEndianPair 8 Word64LE Word64BE) instance LiftedPrim Word64BE -deriving via (ViaEndianPair Int64LE Int64BE) instance LiftedPrim Int64BE +deriving via (ViaEndianPair 8 Int64LE Int64BE) instance LiftedPrim Int64BE -deriving via (ViaEndianPair FloatLE FloatBE) instance LiftedPrim FloatBE +deriving via (ViaEndianPair 4 FloatLE FloatBE) instance LiftedPrim FloatBE -deriving via (ViaEndianPair DoubleLE DoubleBE) instance LiftedPrim DoubleBE +deriving via (ViaEndianPair 8 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 () diff --git a/src/Dahdit/LiftedPrimArray.hs b/src/Dahdit/LiftedPrimArray.hs --- a/src/Dahdit/LiftedPrimArray.hs +++ b/src/Dahdit/LiftedPrimArray.hs @@ -25,7 +25,7 @@ , writeArrayLiftedInElems ) import Dahdit.Proxy (proxyFor, proxyForF) -import Dahdit.Sizes (ByteCount (..), ByteSized (..), ElemCount (..), StaticByteSized (..)) +import Dahdit.Sizes (ByteCount (..), ElemCount (..), StaticByteSized (..)) import Data.Coerce (coerce) import Data.Default (Default (..)) import Data.Foldable (for_) @@ -52,34 +52,31 @@ 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 :: (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 :: (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 :: (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 :: (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 :: (PrimMonad m) => LiftedPrimArray a -> m (MutableLiftedPrimArray (PrimState m) a) unsafeThawLiftedPrimArray (LiftedPrimArray arr) = fmap MutableLiftedPrimArray (unsafeThawByteArray arr) -liftedPrimArrayFromListN :: LiftedPrim a => ElemCount -> [a] -> LiftedPrimArray a +liftedPrimArrayFromListN :: (LiftedPrim a) => ElemCount -> [a] -> LiftedPrimArray a liftedPrimArrayFromListN n xs = LiftedPrimArray $ runByteArray $ do let elemSize = staticByteSize (proxyForF xs) len = coerce n * coerce elemSize @@ -91,22 +88,22 @@ modifySTRef' offRef (elemSize +) pure arr -liftedPrimArrayFromList :: LiftedPrim a => [a] -> LiftedPrimArray a +liftedPrimArrayFromList :: (LiftedPrim a) => [a] -> LiftedPrimArray a liftedPrimArrayFromList xs = liftedPrimArrayFromListN (coerce (length xs)) xs -generateLiftedPrimArray :: LiftedPrim a => ElemCount -> (ElemCount -> a) -> LiftedPrimArray a +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 :: (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 :: (LiftedPrim a) => LiftedPrimArray a -> ElemCount -> ElemCount -> LiftedPrimArray a cloneLiftedPrimArray pa@(LiftedPrimArray arr) off len = let elemSize = staticByteSize (proxyForF pa) byteOff = coerce off * elemSize @@ -114,7 +111,7 @@ arr' = cloneByteArray arr (coerce byteOff) (coerce byteLen) in LiftedPrimArray arr' -replicateLiftedPrimArray :: LiftedPrim a => ElemCount -> a -> LiftedPrimArray a +replicateLiftedPrimArray :: (LiftedPrim a) => ElemCount -> a -> LiftedPrimArray a replicateLiftedPrimArray len val = LiftedPrimArray $ runByteArray $ do let elemSize = staticByteSize (proxyFor val) byteLen = coerce len * elemSize diff --git a/src/Dahdit/Mem.hs b/src/Dahdit/Mem.hs --- a/src/Dahdit/Mem.hs +++ b/src/Dahdit/Mem.hs @@ -1,103 +1,118 @@ module Dahdit.Mem - ( IxPtr (..) + ( MemPtr (..) + , emptyMemPtr + , MutableMem (..) , ReadMem (..) , readSBSMem , viewSBSMem , viewBSMem , viewVecMem + , mutViewVecMem , WriteMem (..) , writeSBSMem - , allocBAMem - , allocPtrMem - , freezeBAMem - , freezeSBSMem - , freezeBSMem - , freezeVecMem - , mutAllocBAMem - , mutFreezeBAMem - , mutAllocVecMem - , mutFreezeVecMem + , withBAMem + , withSBSMem + , withVecMem + , withBSMem ) where -import Control.Monad.Primitive (PrimMonad (..), unsafeIOToPrim) -import Control.Monad.ST (runST) +import Control.Monad.Primitive (MonadPrim, PrimMonad (..), RealWorld) 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, sizeofMutableByteArray, unsafeFreezeByteArray) +import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray, cloneByteArray, copyByteArray, copyByteArrayToPtr, freezeByteArray, newByteArray, unsafeFreezeByteArray, unsafeThawByteArray) import Data.Primitive.Ptr (copyPtrToMutableByteArray) -import Data.Vector.Storable (MVector, Vector) +import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as VS +import Data.Vector.Storable.Mutable (IOVector) import qualified Data.Vector.Storable.Mutable as VSM import Data.Word (Word8) -import Foreign.ForeignPtr (newForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Marshal.Alloc (callocBytes, finalizerFree, free) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrBytes, withForeignPtr) 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) +data MemPtr s = MemPtr + { mpForeign :: !(ForeignPtr Word8) + , mpOffset :: !ByteCount + , mpLength :: !ByteCount + } + deriving stock (Eq, Ord, Show) -class ReadMem r where - indexMemInBytes :: LiftedPrim a => r -> ByteCount -> a - cloneArrayMemInBytes :: r -> ByteCount -> ByteCount -> ByteArray +emptyMemPtr :: IO (MemPtr RealWorld) +emptyMemPtr = allocPtrMem 0 -instance ReadMem ByteArray where - indexMemInBytes = indexArrayLiftedInBytes - cloneArrayMemInBytes arr off len = cloneByteArray arr (coerce off) (coerce len) +withMemPtr :: MemPtr RealWorld -> (Ptr Word8 -> IO a) -> IO a +withMemPtr (MemPtr fp off _) f = withForeignPtr fp (\ptr -> f (plusPtr ptr (coerce off))) -clonePtr :: Ptr Word8 -> ByteCount -> ByteCount -> ByteArray -clonePtr ptr off len = runST $ do - let wptr = coerce (plusPtr ptr (coerce off)) :: Ptr Word8 +class (PrimMonad m) => MutableMem r w m | w m -> r where + unsafeThawMem :: r -> m w + unsafeUseThawedMem :: r -> (w -> m a) -> m a + unsafeUseThawedMem r f = unsafeThawMem r >>= f + unsafeFreezeMem :: w -> m r + unsafeUseFrozenMem :: w -> (r -> m a) -> m a + unsafeUseFrozenMem w f = unsafeFreezeMem w >>= f + +instance (MonadPrim s m) => MutableMem ByteArray (MutableByteArray s) m where + unsafeThawMem = unsafeThawByteArray + unsafeFreezeMem = unsafeFreezeByteArray + +instance MutableMem (VS.Vector Word8) (IOVector Word8) IO where + unsafeThawMem = VS.unsafeThaw + unsafeFreezeMem = VS.unsafeFreeze + +class (PrimMonad m) => ReadMem r m where + indexMemInBytes :: (LiftedPrim a) => r -> ByteCount -> m a + cloneArrayMemInBytes :: r -> ByteCount -> ByteCount -> m ByteArray + +instance (PrimMonad m) => ReadMem ByteArray m where + indexMemInBytes arr off = pure (indexArrayLiftedInBytes arr off) + cloneArrayMemInBytes arr off len = pure (cloneByteArray arr (coerce off) (coerce len)) + +cloneMemPtr :: MemPtr RealWorld -> ByteCount -> ByteCount -> IO ByteArray +cloneMemPtr mem off len = do marr <- newByteArray (coerce len) - copyPtrToMutableByteArray marr 0 wptr (coerce len) + withMemPtr mem $ \ptr -> do + let wptr = plusPtr ptr (coerce off) :: Ptr Word8 + copyPtrToMutableByteArray marr 0 wptr (coerce len) unsafeFreezeByteArray marr -instance ReadMem (Ptr Word8) where - indexMemInBytes = indexPtrLiftedInBytes - cloneArrayMemInBytes = clonePtr +instance ReadMem (MemPtr RealWorld) IO where + indexMemInBytes mem off = withMemPtr mem (\ptr -> pure (indexPtrLiftedInBytes ptr off)) + cloneArrayMemInBytes = cloneMemPtr -readSBSMem :: ReadMem r => r -> ByteCount -> ByteCount -> ShortByteString -readSBSMem mem off len = let !(ByteArray frozArr) = cloneArrayMemInBytes mem off len in SBS frozArr +readSBSMem :: (ReadMem r m) => r -> ByteCount -> ByteCount -> m ShortByteString +readSBSMem mem off len = do + ByteArray frozArr <- cloneArrayMemInBytes mem off len + pure (SBS frozArr) viewSBSMem :: ShortByteString -> ByteArray viewSBSMem (SBS harr) = ByteArray harr -viewBSMem :: ByteString -> Ptr Word8 -viewBSMem bs = - let (fp, _) = BSI.toForeignPtr0 bs - in unsafeForeignPtrToPtr fp +viewBSMem :: ByteString -> MemPtr RealWorld +viewBSMem bs = let (fp, off, len) = BSI.toForeignPtr bs in MemPtr fp (coerce off) (coerce len) -viewVecMem :: Vector Word8 -> Ptr Word8 -viewVecMem vec = - let (fp, _) = VS.unsafeToForeignPtr0 vec - in unsafeForeignPtrToPtr fp +viewVecMem :: Vector Word8 -> MemPtr RealWorld +viewVecMem vec = let (fp, off, len) = VS.unsafeToForeignPtr vec in MemPtr fp (coerce off) (coerce len) -mutViewVecMem :: MVector s Word8 -> Ptr Word8 -mutViewVecMem mvec = - let (fp, _) = VSM.unsafeToForeignPtr0 mvec - in unsafeForeignPtrToPtr fp +mutViewVecMem :: IOVector Word8 -> MemPtr RealWorld +mutViewVecMem mvec = let (fp, off, len) = VSM.unsafeToForeignPtr mvec in MemPtr fp (coerce off) (coerce len) -class PrimMonad m => WriteMem q m where - writeMemInBytes :: LiftedPrim a => a -> q (PrimState m) -> ByteCount -> m () +class (PrimMonad m) => WriteMem q m where + writeMemInBytes :: (LiftedPrim a) => a -> q (PrimState m) -> ByteCount -> m () copyArrayMemInBytes :: ByteArray -> ByteCount -> ByteCount -> q (PrimState m) -> ByteCount -> m () - setMemInBytes :: LiftedPrim a => ByteCount -> a -> q (PrimState m) -> ByteCount -> m () + setMemInBytes :: (LiftedPrim a) => ByteCount -> a -> q (PrimState m) -> ByteCount -> m () -instance PrimMonad m => WriteMem MutableByteArray m where +instance (PrimMonad m) => WriteMem MutableByteArray m where writeMemInBytes val mem off = writeArrayLiftedInBytes mem off val copyArrayMemInBytes arr arrOff arrLen mem off = copyByteArray mem (coerce off) arr (coerce arrOff) (coerce arrLen) setMemInBytes len val mem off = setByteArrayLifted mem off len val -copyPtr :: PrimMonad m => ByteArray -> ByteCount -> ByteCount -> Ptr Word8 -> ByteCount -> m () +copyPtr :: (PrimMonad m) => ByteArray -> ByteCount -> ByteCount -> Ptr Word8 -> ByteCount -> m () copyPtr arr arrOff arrLen ptr off = let wptr = coerce (plusPtr ptr (coerce off)) :: Ptr Word8 in copyByteArrayToPtr wptr arr (coerce arrOff) (coerce arrLen) @@ -109,54 +124,46 @@ for_ [0 .. elemLen - 1] $ \pos -> writePtrLiftedInBytes ptr (off + pos * elemSize) val -instance PrimMonad m => WriteMem IxPtr m where - writeMemInBytes val mem off = writePtrLiftedInBytes (unIxPtr mem) off val - copyArrayMemInBytes arr arrOff arrLen = copyPtr arr arrOff arrLen . unIxPtr - setMemInBytes len val = setPtr len val . unIxPtr +instance WriteMem MemPtr IO where + writeMemInBytes val mem off = withMemPtr mem (\ptr -> writePtrLiftedInBytes ptr off val) + copyArrayMemInBytes arr arrOff arrLen mem off = withMemPtr mem (\ptr -> copyPtr arr arrOff arrLen ptr off) + setMemInBytes len val mem off = withMemPtr mem (\ptr -> setPtr len val ptr off) -writeSBSMem :: WriteMem q m => ShortByteString -> ByteCount -> q (PrimState m) -> ByteCount -> m () +writeSBSMem :: (WriteMem q m) => ShortByteString -> ByteCount -> q (PrimState m) -> ByteCount -> m () writeSBSMem (SBS harr) = copyArrayMemInBytes (ByteArray harr) 0 -freezeBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ByteArray -freezeBAMem marr (ByteCount startOff) (ByteCount endOff) = - if startOff == 0 && endOff == sizeofMutableByteArray marr +withBAMem :: (MonadPrim s m) => ByteCount -> (MutableByteArray s -> m ByteCount) -> m ByteArray +withBAMem len use = do + marr <- newByteArray (coerce len) + len' <- use marr + if len' == len then unsafeFreezeByteArray marr - else freezeByteArray marr startOff (endOff - startOff) - -freezeSBSMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ShortByteString -freezeSBSMem marr startOff endOff = fmap (\(ByteArray harr) -> SBS harr) (freezeBAMem marr startOff endOff) - -freezeBSMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m ByteString -freezeBSMem (IxPtr ptr) startOff endOff = - unsafeIOToPrim $ - BSU.unsafePackCStringFinalizer - (plusPtr ptr (unByteCount startOff)) - (unByteCount (endOff - startOff)) - (free ptr) - -freezeVecMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m (Vector Word8) -freezeVecMem (IxPtr ptr) _ len = unsafeIOToPrim (fmap (\fp -> VS.unsafeFromForeignPtr0 fp (coerce len)) (newForeignPtr finalizerFree ptr)) + else freezeByteArray marr 0 (coerce len') -allocPtrMem :: PrimMonad m => ByteCount -> ByteCount -> m (IxPtr (PrimState m), Maybe (IO ())) -allocPtrMem off len = do - let cap = off + len - ptr <- unsafeIOToPrim (callocBytes (unByteCount cap)) - pure (IxPtr ptr, Just (free ptr)) +withSBSMem :: (MonadPrim s m) => ByteCount -> (MutableByteArray s -> m ByteCount) -> m ShortByteString +withSBSMem len use = fmap (\(ByteArray arr) -> SBS arr) (withBAMem len use) -allocBAMem :: PrimMonad m => ByteCount -> ByteCount -> m (MutableByteArray (PrimState m), Maybe (IO ())) -allocBAMem off len = do - let cap = off + len - arr <- newByteArray (unByteCount cap) - pure (arr, Nothing) +allocPtrMem :: ByteCount -> IO (MemPtr RealWorld) +allocPtrMem len = do + fp <- mallocForeignPtrBytes (coerce len) + pure (MemPtr fp 0 len) -mutAllocBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m (MutableByteArray (PrimState m), Maybe (IO ())) -mutAllocBAMem u _ _ = pure (u, Nothing) +freezeVecMem :: MemPtr RealWorld -> ByteCount -> Vector Word8 +freezeVecMem (MemPtr fp off _) len = + VS.unsafeFromForeignPtr fp (coerce off) (coerce (off + len)) -mutFreezeBAMem :: PrimMonad m => MutableByteArray (PrimState m) -> ByteCount -> ByteCount -> m ByteCount -mutFreezeBAMem _ _ = pure +freezeBSMem :: MemPtr RealWorld -> ByteCount -> ByteString +freezeBSMem (MemPtr fp off _) len = + BSI.fromForeignPtr fp (coerce off) (coerce (off + len)) -mutAllocVecMem :: PrimMonad m => MVector (PrimState m) Word8 -> ByteCount -> ByteCount -> m (IxPtr (PrimState m), Maybe (IO ())) -mutAllocVecMem u _ _ = pure (IxPtr (mutViewVecMem u), Nothing) +withVecMem :: ByteCount -> (MemPtr RealWorld -> IO ByteCount) -> IO (Vector Word8) +withVecMem len use = do + mem <- allocPtrMem len + len' <- use mem + pure (freezeVecMem mem len') -mutFreezeVecMem :: PrimMonad m => IxPtr (PrimState m) -> ByteCount -> ByteCount -> m ByteCount -mutFreezeVecMem _ _ = pure +withBSMem :: ByteCount -> (MemPtr RealWorld -> IO ByteCount) -> IO ByteString +withBSMem len use = do + mem <- allocPtrMem len + len' <- use mem + pure (freezeBSMem mem len') diff --git a/src/Dahdit/Nums.hs b/src/Dahdit/Nums.hs --- a/src/Dahdit/Nums.hs +++ b/src/Dahdit/Nums.hs @@ -126,42 +126,42 @@ deriving stock (Show) deriving newtype (Eq, Ord, Num, Real, Fractional, Floating, RealFrac, Default) -instance EndianPair Word16LE Word16BE where +instance EndianPair 2 Word16LE Word16BE where toLittleEndian = Word16LE . swapEndian . unWord16BE toBigEndian = Word16BE . swapEndian . unWord16LE -instance EndianPair Int16LE Int16BE where +instance EndianPair 2 Int16LE Int16BE where toLittleEndian = Int16LE . swapEndian . unInt16BE toBigEndian = Int16BE . swapEndian . unInt16LE -instance EndianPair Word24LE Word24BE where +instance EndianPair 3 Word24LE Word24BE where toLittleEndian = Word24LE . swapEndian . unWord24BE toBigEndian = Word24BE . swapEndian . unWord24LE -instance EndianPair Int24LE Int24BE where +instance EndianPair 3 Int24LE Int24BE where toLittleEndian = Int24LE . swapEndian . unInt24BE toBigEndian = Int24BE . swapEndian . unInt24LE -instance EndianPair Word32LE Word32BE where +instance EndianPair 4 Word32LE Word32BE where toLittleEndian = Word32LE . swapEndian . unWord32BE toBigEndian = Word32BE . swapEndian . unWord32LE -instance EndianPair Int32LE Int32BE where +instance EndianPair 4 Int32LE Int32BE where toLittleEndian = Int32LE . swapEndian . unInt32BE toBigEndian = Int32BE . swapEndian . unInt32LE -instance EndianPair Word64LE Word64BE where +instance EndianPair 8 Word64LE Word64BE where toLittleEndian = Word64LE . swapEndian . unWord64BE toBigEndian = Word64BE . swapEndian . unWord64LE -instance EndianPair Int64LE Int64BE where +instance EndianPair 8 Int64LE Int64BE where toLittleEndian = Int64LE . swapEndian . unInt64BE toBigEndian = Int64BE . swapEndian . unInt64LE -instance EndianPair FloatLE FloatBE where +instance EndianPair 4 FloatLE FloatBE where toLittleEndian = FloatLE . swapEndian . unFloatBE toBigEndian = FloatBE . swapEndian . unFloatLE -instance EndianPair DoubleLE DoubleBE where +instance EndianPair 8 DoubleLE DoubleBE where toLittleEndian = DoubleLE . swapEndian . unDoubleBE toBigEndian = DoubleBE . swapEndian . unDoubleLE diff --git a/src/Dahdit/Proxy.hs b/src/Dahdit/Proxy.hs --- a/src/Dahdit/Proxy.hs +++ b/src/Dahdit/Proxy.hs @@ -1,12 +1,14 @@ module Dahdit.Proxy ( proxyFor , proxyForF + , proxyForRepF , proxyForFun , proxyForNatF ) where import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic (..)) import GHC.TypeLits (Nat) proxyFor :: a -> Proxy a @@ -14,6 +16,9 @@ proxyForF :: f a -> Proxy a proxyForF _ = Proxy + +proxyForRepF :: f t -> Rep t a -> Proxy (Rep t) +proxyForRepF _ _ = Proxy proxyForFun :: (a -> x) -> Proxy a proxyForFun _ = Proxy diff --git a/src/Dahdit/Run.hs b/src/Dahdit/Run.hs --- a/src/Dahdit/Run.hs +++ b/src/Dahdit/Run.hs @@ -1,26 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} module Dahdit.Run ( GetError (..) , prettyGetError , runGetInternal + , GetIncEnv (..) + , newGetIncEnv + , GetIncChunk (..) + , GetIncRequest (..) + , GetIncSuspend (..) + , GetIncCb + , runGetIncInternal , runCount , runPutInternal ) where import Control.Applicative (Alternative (..)) -import Control.Exception (Exception (..), onException) +import Control.Exception (Exception (..)) import Control.Monad (replicateM_, unless) import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) -import Control.Monad.Free.Church (F (..)) -import Control.Monad.Primitive (PrimBase, PrimMonad (..), unsafeIOToPrim, unsafePrimToIO) +import Control.Monad.Free.Church (F (..), iterM) +import Control.Monad.Free.Class (MonadFree (..)) +import Control.Monad.Primitive (MonadPrim, PrimMonad (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) -import Control.Monad.ST.Strict (ST, runST) import Control.Monad.State.Strict (MonadState, State, runState) import qualified Control.Monad.State.Strict as State -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Free (FreeT (..), iterT, wrap) +import Control.Monad.Trans (MonadTrans (..)) +import Control.Monad.Trans.Free.Church (FT (..), iterT) import Control.Monad.Trans.Maybe (MaybeT (..)) import Dahdit.Free ( Get (..) @@ -67,9 +75,11 @@ import Data.Foldable (for_, toList) import Data.Int (Int8) import Data.Maybe (fromJust) -import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar, writeMutVar) -import Data.STRef.Strict (STRef, newSTRef, readSTRef, writeSTRef) +import Data.Primitive.MutVar (MutVar, modifyMutVar', newMutVar, readMutVar, writeMutVar) +import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as T import Data.Word (Word8) -- Sizes: @@ -92,132 +102,231 @@ -- Get: data GetError - = GetErrorParseNeed !String !ByteCount !ByteCount - | GetErrorScopedMismatch !ByteCount !ByteCount - | GetErrorFail !String + = GetErrorLocalCap !Text !ByteCount !ByteCount + | GetErrorScopedMismatch !ScopeMode !ByteCount !ByteCount + | GetErrorFail !Text + | GetErrorGlobalCap !Text !ByteCount !ByteCount + | GetErrorRemaining !ByteCount deriving stock (Eq, Show) instance Exception GetError where - displayException = prettyGetError + displayException = T.unpack . prettyGetError -prettyGetError :: GetError -> String +prettyGetError :: GetError -> Text prettyGetError = \case - GetErrorParseNeed nm ac bc -> "End of input parsing " ++ nm ++ " (have " ++ show (unByteCount ac) ++ " bytes, need " ++ show (unByteCount bc) ++ ")" - GetErrorScopedMismatch ac bc -> "Did not parse enough scoped input (read " ++ show (unByteCount ac) ++ " bytes, expected " ++ show (unByteCount bc) ++ ")" - GetErrorFail msg -> "User error: " ++ msg + GetErrorLocalCap nm ac bc -> "End of chunk parsing " <> nm <> " (have " <> T.pack (show (unByteCount ac)) <> " bytes, need " <> T.pack (show (unByteCount bc)) <> ")" + GetErrorScopedMismatch sm ac bc -> + let ty = case sm of ScopeModeExact -> "exact"; ScopeModeWithin -> "within" + in "Did not parse " <> ty <> " scoped input (read " <> T.pack (show (unByteCount ac)) <> " bytes, expected " <> T.pack (show (unByteCount bc)) <> ")" + GetErrorFail msg -> "User error: " <> msg + GetErrorGlobalCap nm ac bc -> "Hit limit parsing " <> nm <> " (allowed " <> T.pack (show (unByteCount ac)) <> " bytes, need " <> T.pack (show (unByteCount bc)) <> ")" + GetErrorRemaining ac -> "Cannot read remaining length in stream context (read " <> T.pack (show (unByteCount ac)) <> ")" -data GetEnv s r = GetEnv - { geOff :: !(STRef s ByteCount) - -- ^ Offset from buffer start (in bytes) - , geCap :: !ByteCount - -- ^ Capacity of buffer segment - , geArray :: !r +-- | Get from a single buffer +runGetInternal :: (ReadMem r m) => ByteCount -> Get a -> ByteCount -> r -> m (Either GetError a, ByteCount) +runGetInternal off act cap mem = do + let chunk = GetIncChunk off cap mem + env <- newGetIncEnv (Just (cap - off)) chunk + (ea, _, off') <- runGetIncInternal act env (const (pure Nothing)) + pure (ea, off') + +-- Get inc + +data GetIncChunk r = GetIncChunk + { gicLocalOff :: !ByteCount + -- ^ Offset from start of local buffer to data + , gicLocalCap :: !ByteCount + -- ^ Capacity of local buffer + , gicArray :: !r -- ^ Source buffer } -newGetEnv :: ByteCount -> ByteCount -> r -> ST s (GetEnv s r) -newGetEnv off cap mem = do - offRef <- newSTRef off - pure (GetEnv offRef cap mem) +data GetIncEnv s r = GetIncEnv + { gieGlobalAbs :: !(MutVar s ByteCount) + -- ^ Offset from start of parsing (0) to current position + , gieGlobalRel :: !(MutVar s ByteCount) + -- ^ Offset from start of parsing (0) to start of buffer + -- It will always be the case that gloRel <= gloAbs + , gieGlobalCap :: !(MutVar s (Seq ByteCount)) + -- ^ Stack of maximum capcacity (across all chunks) + -- Top of stack is end of sequence. + -- This will be narrowed to check scoped length. + , gieCurChunk :: !(MutVar s (GetIncChunk r)) + -- ^ Current chunk + , gieLookAhead :: !(MutVar s (Seq ByteCount)) + -- ^ Stack of look ahead points (in absolute position) + -- Top of stack is end of sequence. + } -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) +newGetIncEnv :: (MonadPrim s m) => Maybe ByteCount -> GetIncChunk r -> m (GetIncEnv s r) +newGetIncEnv mayCap chunk = do + gloAbsVar <- newMutVar 0 + gloRelVar <- newMutVar 0 + gloCapVar <- newMutVar (maybe Empty Seq.singleton mayCap) + curChunkVar <- newMutVar chunk + lookAheadVar <- newMutVar Empty + pure (GetIncEnv gloAbsVar gloRelVar gloCapVar curChunkVar lookAheadVar) -runGetEff :: GetEff s r a -> GetEnv s r -> ST s (Either GetError a) -runGetEff act env = runExceptT (runReaderT (unGetEff act) env) +-- | A request for more data. Includes absolute position, offset in the current buffer, and required length. +data GetIncRequest = GetIncRequest + { girAbsPos :: !ByteCount + , girBaseOff :: !ByteCount + , girNeedLength :: !ByteCount + } + deriving stock (Eq, Ord, Show) -instance MonadFail (GetEff s r) where - fail = GetEff . throwError . GetErrorFail +-- | See 'GetIncCb' - this is the functor-ized version so we can suspend execution. +data GetIncSuspend z x = GetIncSuspend !GetIncRequest !(Maybe z -> x) + deriving stock (Functor) -stGetEff :: ST s a -> GetEff s r a -stGetEff = GetEff . lift . lift +type GetIncSuspendChunk r = GetIncSuspend (GetIncChunk r) -newtype GetRun s r a = GetRun {unGetRun :: FreeT GetF (GetEff s r) a} - deriving newtype (Functor, Applicative, Monad) +-- Should not implement 'MonadReader' so we can prevent scoped operations like 'local' +newtype GetIncM s r m a = GetIncM {unGetIncM :: ReaderT (GetIncEnv s r) (ExceptT GetError (FT (GetIncSuspendChunk r) m)) a} + deriving newtype + ( Functor + , Applicative + , Monad + , MonadError GetError + , MonadFree (GetIncSuspendChunk r) + ) -guardReadBytes :: String -> ByteCount -> GetEff s r ByteCount +instance MonadTrans (GetIncM s r) where + lift = GetIncM . lift . lift . lift + +-- | Return new chunk containing enough data (or nothing). +type GetIncCb z m = GetIncRequest -> m (Maybe z) + +type GetIncCbChunk r m = GetIncCb (GetIncChunk r) m + +pushMutVar :: (MonadPrim s m) => MutVar s (Seq a) -> a -> m () +pushMutVar v a = modifyMutVar' v (:|> a) + +popMutVar :: (MonadPrim s m) => MutVar s (Seq a) -> m () +popMutVar v = modifyMutVar' v (\case Empty -> Empty; as :|> _ -> as) + +peekMutVar :: (MonadPrim s m) => MutVar s (Seq a) -> m (Maybe a) +peekMutVar = fmap (\case Empty -> Nothing; _ :|> a -> Just a) . readMutVar + +runGetIncM :: (MonadPrim s m) => GetIncM s r m a -> GetIncEnv s r -> GetIncCbChunk r m -> m (Either GetError a) +runGetIncM m env cb = + runFT + (runExceptT (runReaderT (unGetIncM m) env)) + pure + (\k2 (GetIncSuspend req k1) -> cb req >>= k2 . k1) + +guardReadBytes :: (MonadPrim s m) => Text -> ByteCount -> GetIncM s r m (ByteCount, GetIncChunk r, ByteCount) guardReadBytes nm bc = do - GetEnv offRef cap _ <- ask - off <- stGetEff (readSTRef offRef) - let ac = cap - off - if bc > ac - then throwError (GetErrorParseNeed nm ac bc) - else pure off + GetIncEnv gloAbsRef gloRelRef capStackRef chunkRef lookStackRef <- GetIncM ask + -- First check if we're in cap + gloAbsStart <- lift (readMutVar gloAbsRef) + let gloAbsEnd = gloAbsStart + bc + mayCap <- lift (peekMutVar capStackRef) + case mayCap of + Just cap | gloAbsEnd > cap -> throwError (GetErrorGlobalCap nm cap gloAbsEnd) + _ -> pure () + -- Now check that we have enough in the local buf + gloRel <- lift (readMutVar gloRelRef) + oldChunk@(GetIncChunk oldOff oldCap _) <- lift (readMutVar chunkRef) + let oldLocOffStart = gloAbsStart - gloRel + oldOff + oldLocOffEnd = oldLocOffStart + bc + (newChunk, newLocOffStart) <- + if oldLocOffEnd <= oldCap + then pure (oldChunk, oldLocOffStart) + else do + lookStack <- lift (readMutVar lookStackRef) + let gloBaseStart = case lookStack of Empty -> gloAbsStart; x :<| _ -> x + baseOffStart = gloBaseStart - gloRel + oldOff + baseOffEnd = gloAbsStart - gloRel + oldOff + bc + let needLength = baseOffEnd - baseOffStart + req = GetIncRequest gloAbsStart baseOffStart needLength + wrap $ GetIncSuspend req $ \case + Nothing -> throwError (GetErrorLocalCap nm oldCap baseOffEnd) + Just newChunk@(GetIncChunk newOff newCap _) -> do + let newEnd = newOff + needLength + unless (newEnd <= newCap) (throwError (GetErrorLocalCap nm newCap newOff)) + lift (writeMutVar chunkRef newChunk) + lift (writeMutVar gloRelRef gloBaseStart) + pure (newChunk, gicLocalOff newChunk) + pure (gloAbsEnd, newChunk, newLocOffStart) -readBytes :: String -> ByteCount -> (r -> ByteCount -> a) -> GetEff s r a +-- Memory read function takes local start offset +readBytes :: (MonadPrim s m) => Text -> ByteCount -> (r -> ByteCount -> m a) -> GetIncM s r m a readBytes nm bc f = do - off <- guardReadBytes nm bc - GetEnv offRef _ mem <- ask - stGetEff $ do - let a = f mem off - newOff = off + bc - writeSTRef offRef newOff - pure a + (gloAbsEnd, newChunk, newLocOffStart) <- guardReadBytes nm bc + let mem = gicArray newChunk + a <- lift (f mem newLocOffStart) + gloAbsRef <- GetIncM (asks gieGlobalAbs) + lift (writeMutVar gloAbsRef gloAbsEnd) + pure a -readScope :: ReadMem r => GetScopeF (GetEff s r a) -> GetEff s r a +readScope :: (MonadPrim s m, ReadMem r m) => GetScopeF (GetIncM s r m a) -> GetIncM s r m a readScope (GetScopeF sm bc g k) = do - GetEnv offRef oldCap _ <- ask - oldOff <- stGetEff (readSTRef offRef) - let oldAvail = oldCap - oldOff - if bc > oldAvail - then throwError (GetErrorParseNeed "scope" oldAvail bc) - else do - let newCap = oldOff + bc - a <- local (\ge -> ge {geCap = newCap}) (mkGetEff g) - case sm of - ScopeModeWithin -> k a - ScopeModeExact -> do - newOff <- stGetEff (readSTRef offRef) - let actualBc = newOff - oldOff - if actualBc == bc - then k a - else throwError (GetErrorScopedMismatch actualBc bc) + GetIncEnv gloAbsRef _ capStackRef _ _ <- GetIncM ask + gloAbsStart <- lift (readMutVar gloAbsRef) + let gloAbsMax = gloAbsStart + bc + mayCap <- lift (peekMutVar capStackRef) + case mayCap of + Just cap + | sm == ScopeModeExact && gloAbsMax > cap -> + throwError (GetErrorGlobalCap "scope" cap gloAbsMax) + _ -> pure () + lift (pushMutVar capStackRef gloAbsMax) + a <- interpGetInc g + lift (popMutVar capStackRef) + gloAbsEnd <- lift (readMutVar gloAbsRef) + let actualBc = gloAbsEnd - gloAbsStart + if (sm == ScopeModeExact && actualBc == bc) || (sm == ScopeModeWithin && actualBc <= bc) + then k a + else throwError (GetErrorScopedMismatch sm actualBc bc) -readStaticSeq :: ReadMem r => GetStaticSeqF (GetEff s r a) -> GetEff s r a +readStaticSeq :: (MonadPrim s m, ReadMem r m) => GetStaticSeqF (GetIncM s r m a) -> GetIncM s r m a readStaticSeq gss@(GetStaticSeqF ec g k) = do let bc = getStaticSeqSize gss _ <- guardReadBytes "static sequence" bc - ss <- Seq.replicateA (coerce ec) (mkGetEff g) + ss <- Seq.replicateA (coerce ec) (interpGetInc g) k ss -readStaticArray :: ReadMem r => GetStaticArrayF (GetEff s r a) -> GetEff s r a +readStaticArray :: (MonadPrim s m, ReadMem r m) => GetStaticArrayF (GetIncM s r m a) -> GetIncM s r m a readStaticArray gsa@(GetStaticArrayF _ _ k) = do let bc = getStaticArraySize gsa sa <- readBytes "static vector" bc (\mem off -> cloneArrayMemInBytes mem off bc) k (LiftedPrimArray sa) -readLookAhead :: ReadMem r => GetLookAheadF (GetEff s r a) -> GetEff s r a +readLookAhead :: (MonadPrim s m, ReadMem r m) => GetLookAheadF (GetIncM s r m a) -> GetIncM s r m a readLookAhead (GetLookAheadF g k) = do - offRef <- asks geOff - startOff <- stGetEff (readSTRef offRef) - a <- mkGetEff g - stGetEff (writeSTRef offRef startOff) + GetIncEnv gloAbsRef _ _ _ lookStackRef <- GetIncM ask + gloAbs <- lift (readMutVar gloAbsRef) + lift (pushMutVar lookStackRef gloAbs) + a <- interpGetInc g + lift (popMutVar lookStackRef) + lift (writeMutVar gloAbsRef gloAbs) k a -execGetRun :: ReadMem r => GetF (GetEff s r a) -> GetEff s r a -execGetRun = \case - 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 +interpGetInc :: (MonadPrim s m, ReadMem r m) => Get a -> GetIncM s r m a +interpGetInc (Get g) = flip iterM g $ \case + 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 -> readBytes "ShortByteString" bc (\mem off -> readSBSMem mem off bc) >>= k GetFStaticSeq gss -> readStaticSeq gss @@ -225,35 +334,28 @@ GetFByteArray bc k -> readBytes "ByteArray" bc (\mem off -> cloneArrayMemInBytes mem off bc) >>= k GetFScope gs -> readScope gs - GetFSkip bc k -> readBytes "skip" bc (\_ _ -> ()) *> k + GetFSkip bc k -> readBytes "skip" bc (\_ _ -> pure ()) >> k GetFLookAhead gla -> readLookAhead gla GetFRemainingSize k -> do - GetEnv offRef cap _ <- ask - off <- stGetEff (readSTRef offRef) - k (cap - off) - GetFFail msg -> fail msg - -runGetRun :: ReadMem r => GetRun s r a -> GetEnv s r -> ST s (Either GetError a) -runGetRun = runGetEff . iterGetRun - -iterGetRun :: ReadMem r => GetRun s r a -> GetEff s r a -iterGetRun act = iterT execGetRun (unGetRun act) - -mkGetRun :: Get a -> GetRun s r a -mkGetRun (Get (F w)) = GetRun (w pure wrap) - -mkGetEff :: ReadMem r => Get a -> GetEff s r a -mkGetEff = iterGetRun . mkGetRun + GetIncEnv gloAbsRef _ capStackRef _ _ <- GetIncM ask + gloAbs <- lift (readMutVar gloAbsRef) + capStack <- lift (readMutVar capStackRef) + case capStack of + Empty -> throwError (GetErrorRemaining gloAbs) + _ :|> cap -> k (cap - gloAbs) + GetFFail msg -> throwError (GetErrorFail msg) -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) +runGetIncInternal :: (MonadPrim s m, ReadMem r m) => Get a -> GetIncEnv s r -> GetIncCbChunk r m -> m (Either GetError a, ByteCount, ByteCount) +runGetIncInternal getter env cb = do + let m = interpGetInc getter + res <- runGetIncM m env cb + gloAbs <- readMutVar (gieGlobalAbs env) + gloRel <- readMutVar (gieGlobalRel env) + curChunk <- readMutVar (gieCurChunk env) + let baseOff = gloAbs - gloRel + gicLocalOff curChunk + pure (res, gloAbs, baseOff) --- Put unsafe: +-- Put: data PutEnv s q = PutEnv { peOff :: !(MutVar s ByteCount) @@ -264,7 +366,7 @@ -- ^ Destination buffer } -newPutEnv :: PrimMonad m => ByteCount -> ByteCount -> q (PrimState m) -> m (PutEnv (PrimState m) q) +newPutEnv :: (PrimMonad m) => ByteCount -> ByteCount -> q (PrimState m) -> m (PutEnv (PrimState m) q) newPutEnv off cap mem = do offRef <- newMutVar off pure (PutEnv offRef cap mem) @@ -277,13 +379,13 @@ runPutEff :: PutEff q m a -> PutEnv (PrimState m) q -> m a runPutEff act = runReaderT (unPutEff act) -stPutEff :: Monad m => m a -> PutEff q m a +stPutEff :: (Monad m) => m a -> PutEff q m a stPutEff = PutEff . lift -newtype PutRun q m a = PutRun {unPutRun :: FreeT PutF (PutEff q m) a} +newtype PutRun q m a = PutRun {unPutRun :: FT PutF (PutEff q m) a} deriving newtype (Functor, Applicative, Monad) -writeBytes :: PrimMonad m => ByteCount -> (q (PrimState m) -> ByteCount -> m ()) -> PutEff q m () +writeBytes :: (PrimMonad m) => ByteCount -> (q (PrimState m) -> ByteCount -> m ()) -> PutEff q m () writeBytes bc f = do PutEnv offRef _ mem <- ask stPutEff $ do @@ -292,7 +394,7 @@ let newOff = off + bc writeMutVar offRef newOff -writeStaticSeq :: WriteMem q m => PutStaticSeqF (PutEff q m a) -> PutEff q m a +writeStaticSeq :: (WriteMem q m) => PutStaticSeqF (PutEff q m a) -> PutEff q m a writeStaticSeq (PutStaticSeqF n mz p s k) = do for_ (take (coerce n) (toList s)) $ \a -> do mkPutEff (p a) @@ -302,7 +404,7 @@ replicateM_ (coerce n - e) q k -writeStaticArray :: WriteMem q m => PutStaticArrayF (PutEff q m a) -> PutEff q m a +writeStaticArray :: (WriteMem q m) => PutStaticArrayF (PutEff q m a) -> PutEff q m a writeStaticArray psa@(PutStaticArrayF needElems mz a@(LiftedPrimArray ba) k) = do let elemSize = putStaticArrayElemSize psa haveElems = sizeofLiftedPrimArray a @@ -317,52 +419,52 @@ Just z -> writeBytes extraBc (setMemInBytes extraBc z) k -execPutRun :: WriteMem q m => PutF (PutEff q m a) -> PutEff q m a +execPutRun :: (WriteMem q m) => PutF (PutEff q m a) -> PutEff q m a execPutRun = \case - PutFWord8 x k -> writeBytes 1 (writeMemInBytes x) *> k - PutFInt8 x k -> writeBytes 1 (writeMemInBytes x) *> k - 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 + 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 -> - writeBytes bc (writeSBSMem sbs bc) *> k + writeBytes bc (writeSBSMem sbs bc) >> k PutFStaticSeq pss -> writeStaticSeq pss PutFStaticArray psa -> writeStaticArray psa PutFByteArray bc barr k -> - writeBytes bc (copyArrayMemInBytes barr 0 bc) *> k - PutFStaticHint (PutStaticHintF _ p k) -> mkPutEff p *> k + writeBytes bc (copyArrayMemInBytes barr 0 bc) >> k + PutFStaticHint (PutStaticHintF _ p k) -> mkPutEff p >> k -runPutRun :: WriteMem q m => PutRun q m a -> PutEnv (PrimState m) q -> m a +runPutRun :: (WriteMem q m) => PutRun q m a -> PutEnv (PrimState m) q -> m a runPutRun = runPutEff . iterPutRun -iterPutRun :: WriteMem q m => PutRun q m a -> PutEff q m a +iterPutRun :: (WriteMem q m) => PutRun q m a -> PutEff q m a iterPutRun act = iterT execPutRun (unPutRun act) -mkPutRun :: Monad m => PutM a -> PutRun q m a +mkPutRun :: PutM a -> PutRun q m a mkPutRun (PutM (F w)) = PutRun (w pure wrap) -mkPutEff :: WriteMem q m => PutM a -> PutEff q m a +mkPutEff :: (WriteMem q m) => PutM a -> PutEff q m a mkPutEff = iterPutRun . mkPutRun -runPutUnsafe :: WriteMem q m => ByteCount -> Put -> ByteCount -> q (PrimState m) -> m ByteCount -runPutUnsafe off act len mem = do +runPutInternal :: (WriteMem q m) => ByteCount -> Put -> ByteCount -> q (PrimState m) -> m ByteCount +runPutInternal off act len mem = do let eff = mkPutRun act cap = off + len st@(PutEnv offRef _ _) <- newPutEnv off cap mem @@ -377,42 +479,42 @@ runCountEff :: CountEff a -> ByteCount -> (Maybe a, ByteCount) runCountEff act = runState (runMaybeT (unCountEff act)) -newtype CountRun a = CountRun {unCountRun :: FreeT PutF CountEff a} +newtype CountRun a = CountRun {unCountRun :: FT 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 - 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 - PutFDoubleBE _ k -> State.modify' (8 +) *> k - PutFShortByteString bc _ k -> State.modify' (bc +) *> 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 + 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 + PutFDoubleBE _ k -> State.modify' (8 +) >> k + PutFShortByteString bc _ k -> State.modify' (bc +) >> k PutFStaticSeq pss@(PutStaticSeqF _ _ _ _ k) -> let bc = putStaticSeqSize pss - in State.modify' (bc +) *> k + in State.modify' (bc +) >> k PutFStaticArray psv@(PutStaticArrayF _ _ _ 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 + in State.modify' (bc +) >> k + PutFByteArray bc _ k -> State.modify' (bc +) >> k + PutFStaticHint (PutStaticHintF bc _ k) -> State.modify' (bc +) >> k runCountRun :: CountRun a -> ByteCount -> (Maybe a, ByteCount) runCountRun = runCountEff . iterCountRun @@ -431,14 +533,3 @@ let eff = mkCountRun act (_, bc) = runCountRun eff 0 in bc - --- Put safe: - -primOnExc :: PrimBase m => m a -> Maybe (IO ()) -> m a -primOnExc prim = maybe prim $ \onExc -> - unsafeIOToPrim (onException (unsafePrimToIO prim) onExc) - -runPutInternal :: (PrimBase m, WriteMem q m) => ByteCount -> Put -> ByteCount -> (ByteCount -> ByteCount -> m (q (PrimState m), Maybe (IO ()))) -> (q (PrimState m) -> ByteCount -> ByteCount -> m z) -> m z -runPutInternal off act len mkMem useMem = do - (mem, rel) <- mkMem off len - primOnExc (runPutUnsafe off act len mem >>= useMem mem off) rel diff --git a/src/Dahdit/Sizes.hs b/src/Dahdit/Sizes.hs --- a/src/Dahdit/Sizes.hs +++ b/src/Dahdit/Sizes.hs @@ -1,10 +1,9 @@ +{-# LANGUAGE UndecidableInstances #-} + module Dahdit.Sizes ( ByteCount (..) , ElemCount (..) - , ByteSized (..) , StaticByteSized (..) - , ViaStaticByteSized (..) - , byteSizeFoldable , staticByteSizeFoldable , byteSizeViaStatic ) @@ -34,25 +33,13 @@ , 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.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 Data.Set (Set) -import qualified Data.Set as Set import Data.ShortWord (Int24, Word24) import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, Nat, natVal) -- Counts @@ -64,279 +51,150 @@ deriving stock (Show) deriving newtype (Eq, Ord, Num, Enum, Real, Integral, Default) --- ByteSized - -class ByteSized a where - byteSize :: a -> ByteCount - -instance ByteSized () where - byteSize _ = 0 - -instance ByteSized Word8 where - byteSize _ = 1 - -instance ByteSized Int8 where - byteSize _ = 1 - -instance ByteSized Word16 where - byteSize _ = 2 - -instance ByteSized Int16 where - byteSize _ = 2 - -instance ByteSized Word24 where - byteSize _ = 3 - -instance ByteSized Int24 where - byteSize _ = 3 - -instance ByteSized Word32 where - byteSize _ = 4 - -instance ByteSized Int32 where - byteSize _ = 4 - -instance ByteSized Word64 where - byteSize _ = 8 - -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 - -instance ByteSized Int16LE where - byteSize _ = 2 - -instance ByteSized Word24LE where - byteSize _ = 3 - -instance ByteSized Int24LE where - byteSize _ = 3 - -instance ByteSized Word32LE where - byteSize _ = 4 - -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 DoubleLE where - byteSize _ = 8 - -instance StaticByteSized x => ByteSized (ViaFromIntegral x y) where - byteSize = byteSizeViaStatic - -instance StaticByteSized le => ByteSized (ViaEndianPair le be) where - byteSize = byteSizeViaStatic - -deriving via (ViaEndianPair Word16LE Word16BE) instance ByteSized Word16BE - -deriving via (ViaEndianPair Int16LE Int16BE) instance ByteSized Int16BE - -deriving via (ViaEndianPair Word24LE Word24BE) instance ByteSized Word24BE - -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 = coerce . BSS.length - -instance ByteSized a => ByteSized [a] where - byteSize = byteSizeFoldable - -instance ByteSized a => ByteSized (Seq a) where - byteSize = byteSizeFoldable - -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 +class (KnownNat (StaticSize a)) => StaticByteSized a where + type StaticSize a :: Nat staticByteSize :: Proxy a -> ByteCount + staticByteSize = fromInteger . natVal . staticByteProxy +staticByteProxy :: Proxy a -> Proxy (StaticSize a) +staticByteProxy _ = Proxy + instance StaticByteSized () where + type StaticSize () = 0 staticByteSize _ = 0 instance StaticByteSized Word8 where + type StaticSize Word8 = 1 staticByteSize _ = 1 instance StaticByteSized Int8 where + type StaticSize Int8 = 1 staticByteSize _ = 1 instance StaticByteSized Word16 where + type StaticSize Word16 = 2 staticByteSize _ = 2 instance StaticByteSized Int16 where + type StaticSize Int16 = 2 staticByteSize _ = 2 instance StaticByteSized Word24 where + type StaticSize Word24 = 3 staticByteSize _ = 3 instance StaticByteSized Int24 where + type StaticSize Int24 = 3 staticByteSize _ = 3 instance StaticByteSized Word32 where + type StaticSize Word32 = 4 staticByteSize _ = 4 instance StaticByteSized Int32 where + type StaticSize Int32 = 4 staticByteSize _ = 4 instance StaticByteSized Word64 where + type StaticSize Word64 = 8 staticByteSize _ = 8 instance StaticByteSized Int64 where + type StaticSize Int64 = 8 staticByteSize _ = 8 instance StaticByteSized Float where + type StaticSize Float = 4 staticByteSize _ = 4 instance StaticByteSized Double where + type StaticSize Double = 8 staticByteSize _ = 8 instance StaticByteSized Bool where + type StaticSize Bool = 1 staticByteSize _ = 1 instance StaticByteSized Char where + type StaticSize Char = 1 staticByteSize _ = 1 instance StaticByteSized Int where + type StaticSize Int = 8 staticByteSize _ = 8 instance StaticByteSized Word16LE where + type StaticSize Word16LE = 2 staticByteSize _ = 2 instance StaticByteSized Int16LE where + type StaticSize Int16LE = 2 staticByteSize _ = 2 instance StaticByteSized Word24LE where + type StaticSize Word24LE = 3 staticByteSize _ = 3 instance StaticByteSized Int24LE where + type StaticSize Int24LE = 3 staticByteSize _ = 3 instance StaticByteSized Word32LE where + type StaticSize Word32LE = 4 staticByteSize _ = 4 instance StaticByteSized Int32LE where + type StaticSize Int32LE = 4 staticByteSize _ = 4 instance StaticByteSized Word64LE where + type StaticSize Word64LE = 8 staticByteSize _ = 8 instance StaticByteSized Int64LE where + type StaticSize Int64LE = 8 staticByteSize _ = 8 instance StaticByteSized FloatLE where + type StaticSize FloatLE = 4 staticByteSize _ = 4 instance StaticByteSized DoubleLE where + type StaticSize DoubleLE = 8 staticByteSize _ = 8 -instance StaticByteSized x => StaticByteSized (ViaFromIntegral x y) where +instance (StaticByteSized x, n ~ StaticSize x) => StaticByteSized (ViaFromIntegral n x y) where + type StaticSize (ViaFromIntegral n x y) = n staticByteSize _ = staticByteSize (Proxy :: Proxy x) -instance StaticByteSized le => StaticByteSized (ViaEndianPair le be) where +instance (StaticByteSized le, n ~ StaticSize le) => StaticByteSized (ViaEndianPair n le be) where + type StaticSize (ViaEndianPair n le be) = n staticByteSize _ = staticByteSize (Proxy :: Proxy le) -deriving via (ViaEndianPair Word16LE Word16BE) instance StaticByteSized Word16BE - -deriving via (ViaEndianPair Int16LE Int16BE) instance StaticByteSized Int16BE - -deriving via (ViaEndianPair Word24LE Word24BE) instance StaticByteSized Word24BE - -deriving via (ViaEndianPair Int24LE Int24BE) instance StaticByteSized Int24BE - -deriving via (ViaEndianPair Word32LE Word32BE) instance StaticByteSized Word32BE +deriving via (ViaEndianPair 2 Word16LE Word16BE) instance StaticByteSized Word16BE -deriving via (ViaEndianPair Int32LE Int32BE) instance StaticByteSized Int32BE +deriving via (ViaEndianPair 2 Int16LE Int16BE) instance StaticByteSized Int16BE -deriving via (ViaEndianPair Word64LE Word64BE) instance StaticByteSized Word64BE +deriving via (ViaEndianPair 3 Word24LE Word24BE) instance StaticByteSized Word24BE -deriving via (ViaEndianPair Int64LE Int64BE) instance StaticByteSized Int64BE +deriving via (ViaEndianPair 3 Int24LE Int24BE) instance StaticByteSized Int24BE -deriving via (ViaEndianPair FloatLE FloatBE) instance StaticByteSized FloatBE +deriving via (ViaEndianPair 4 Word32LE Word32BE) instance StaticByteSized Word32BE -deriving via (ViaEndianPair DoubleLE DoubleBE) instance StaticByteSized DoubleBE +deriving via (ViaEndianPair 4 Int32LE Int32BE) instance StaticByteSized Int32BE --- Via +deriving via (ViaEndianPair 8 Word64LE Word64BE) instance StaticByteSized Word64BE -newtype ViaStaticByteSized a = ViaStaticByteSized {unViaStaticByteSized :: a} +deriving via (ViaEndianPair 8 Int64LE Int64BE) instance StaticByteSized Int64BE -instance StaticByteSized a => ByteSized (ViaStaticByteSized a) where - byteSize _ = staticByteSize (Proxy :: Proxy a) +deriving via (ViaEndianPair 4 FloatLE FloatBE) instance StaticByteSized FloatBE -byteSizeFoldable :: (Foldable f, ByteSized a) => f a -> ByteCount -byteSizeFoldable = getSum . foldMap' (Sum . byteSize) +deriving via (ViaEndianPair 8 DoubleLE DoubleBE) instance StaticByteSized DoubleBE staticByteSizeFoldable :: (Foldable f, StaticByteSized a) => f a -> ByteCount staticByteSizeFoldable fa = staticByteSize (proxyForF fa) * coerce (length fa) -byteSizeViaStatic :: StaticByteSized a => a -> ByteCount +byteSizeViaStatic :: (StaticByteSized a) => a -> ByteCount byteSizeViaStatic = staticByteSize . proxyFor diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,12 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + module Main (main) where -import Control.Monad.Primitive (PrimState) +import Control.Applicative (liftA2) +import Control.Monad (replicateM, (>=>)) +import Control.Monad.Primitive (RealWorld) import Dahdit ( Binary (..) - , BinaryTarget (..) + , BinaryGetTarget (..) + , BinaryPutTarget (..) , BoolByte (..) , ByteCount (..) - , ByteSized (..) , ByteString , DoubleBE (..) , DoubleLE (..) @@ -15,6 +20,7 @@ , Generic , Get , GetError (..) + , GetIncRequest (..) , Int16BE , Int16LE , Int24BE @@ -24,22 +30,27 @@ , Int64BE , Int64LE , LiftedPrimArray (..) - , MutBinaryTarget (..) + , MutBinaryPutTarget (..) , Proxy (..) , Put , ShortByteString , StaticByteSized (..) , StaticBytes (..) + , TermBytes16 (..) + , TermBytes8 (..) , ViaGeneric (..) , ViaStaticGeneric (..) , Word16BE - , Word16LE + , Word16LE (..) , Word24BE , Word24LE , Word32BE - , Word32LE + , Word32LE (..) , Word64BE , Word64LE + , decodeEnd + , decodeInc + , encode , getByteArray , getByteString , getDoubleBE @@ -64,6 +75,7 @@ , getStaticArray , getStaticSeq , getTarget + , getText , getWithin , getWord16BE , getWord16LE @@ -97,6 +109,7 @@ , putSeq , putStaticArray , putStaticSeq + , putText , putWord16BE , putWord16LE , putWord24BE @@ -114,59 +127,73 @@ import Data.ByteString.Short (ShortByteString (..)) import qualified Data.ByteString.Short as BSS import Data.Coerce (coerce) +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Int (Int16, Int32, Int64, Int8) import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray, byteArrayFromList, freezeByteArray, newByteArray, sizeofMutableByteArray) import Data.Proxy (asProxyTypeOf) +import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.ShortWord (Int24, Word24) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as VS -import Data.Vector.Storable.Mutable (MVector) +import Data.Vector.Storable.Mutable (IOVector) import qualified Data.Vector.Storable.Mutable as VSM import Data.Word (Word16, Word32, Word64, Word8) import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import System.IO.Unsafe (unsafePerformIO) +import Test.Falsify.Generator (Gen) +import qualified Test.Falsify.Generator as FG +import qualified Test.Falsify.Predicate as FC +import Test.Falsify.Property (Property) +import qualified Test.Falsify.Property as FP +import qualified Test.Falsify.Range as FR import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Falsify (testProperty) import Test.Tasty.HUnit (testCase, (@?=)) -class BinaryTarget z => CaseTarget z where - initSource :: [Word8] -> z - consumeSink :: z -> [Word8] +class (Eq z, Show z) => CaseTarget z where + initSource :: [Word8] -> IO z + consumeSink :: z -> IO [Word8] + sliceBuffer :: z -> ByteCount -> ByteCount -> IO z instance CaseTarget ShortByteString where - initSource = BSS.pack - consumeSink = BSS.unpack + initSource = pure . BSS.pack + consumeSink = pure . BSS.unpack + sliceBuffer buf off len = pure (BSS.take (coerce len) (BSS.drop (coerce off) buf)) instance CaseTarget ByteString where - initSource = BS.pack - consumeSink = BS.unpack + initSource = pure . BS.pack + consumeSink = pure . BS.unpack + sliceBuffer buf off len = pure (BS.take (coerce len) (BS.drop (coerce off) buf)) instance CaseTarget (Vector Word8) where - initSource = VS.fromList - consumeSink = VS.toList + initSource = pure . VS.fromList + consumeSink = pure . VS.toList + sliceBuffer buf off len = pure (VS.take (coerce len) (VS.drop (coerce off) buf)) -class MutBinaryTarget IO u => MutCaseTarget u where +class MutCaseTarget u where newSink :: ByteCount -> IO u freezeSink :: u -> IO [Word8] -instance (s ~ PrimState IO) => MutCaseTarget (MutableByteArray s) where +instance MutCaseTarget (MutableByteArray RealWorld) where newSink = newByteArray . unByteCount freezeSink u = fmap (\(ByteArray arr) -> BSS.unpack (SBS arr)) (freezeByteArray u 0 (sizeofMutableByteArray u)) -instance (s ~ PrimState IO) => MutCaseTarget (MVector s Word8) where +instance MutCaseTarget (IOVector Word8) where newSink = VSM.new . unByteCount - freezeSink = fmap consumeSink . VS.freeze + freezeSink = VS.freeze >=> consumeSink data DynFoo = DynFoo !Word8 !Word16LE deriving stock (Eq, Show, Generic) - deriving (ByteSized, Binary) via (ViaGeneric DynFoo) + deriving (Binary) via (ViaGeneric DynFoo) data StaFoo = StaFoo !Word8 !Word16LE deriving stock (Eq, Show, Generic) - deriving (ByteSized, StaticByteSized, Binary) via (ViaStaticGeneric StaFoo) + deriving (StaticByteSized, Binary) via (ViaStaticGeneric StaFoo) data TagFoo = TagFooOne !Word8 | TagFooTwo !Word16LE deriving stock (Eq, Show, Generic) - deriving (ByteSized, Binary) via (ViaGeneric TagFoo) + deriving (Binary) via (ViaGeneric TagFoo) type StaBytes = StaticBytes 2 @@ -176,11 +203,11 @@ data GetCase where GetCase :: (Show a, Eq a) => String -> Get a -> Maybe (ByteCount, ByteCount, a) -> [Word8] -> GetCase -runGetCase :: CaseTarget z => Proxy z -> GetCase -> TestTree +runGetCase :: (BinaryGetTarget z IO, CaseTarget z) => Proxy z -> GetCase -> TestTree runGetCase p (GetCase name getter mayRes buf) = testCase name $ do - let src = initSource buf `asProxyTypeOf` p - totLen = coerce (length buf) - (result, actOff) = getTarget getter src + src <- initSource buf + let totLen = coerce (length buf) + (result, actOff) <- getTarget getter (src `asProxyTypeOf` p) case (result, mayRes) of (Left _, Nothing) -> pure () (Left err, Just (_, _, expecVal)) -> fail ("Got error <" ++ show err ++ ">, expected value <" ++ show expecVal ++ ">") @@ -193,18 +220,18 @@ data PutCase where PutCase :: String -> Put -> [Word8] -> PutCase -runPutCase :: CaseTarget z => Proxy z -> PutCase -> TestTree +runPutCase :: (BinaryPutTarget z IO, CaseTarget z) => Proxy z -> PutCase -> TestTree runPutCase p (PutCase name putter expecBs) = testCase name $ do let expecBc = coerce (length expecBs) estBc = runCount putter estBc @?= expecBc - let actSink = putTargetUnsafe putter expecBc `asProxyTypeOf` p - actBs = consumeSink actSink - actBc = coerce (length actBs) + actSink <- putTargetUnsafe putter expecBc + actBs <- consumeSink (actSink `asProxyTypeOf` p) + let actBc = coerce (length actBs) actBs @?= expecBs actBc @?= expecBc -mutRunPutCase :: MutCaseTarget z => Proxy z -> PutCase -> TestTree +mutRunPutCase :: (MutBinaryPutTarget z IO, MutCaseTarget z) => Proxy z -> PutCase -> TestTree mutRunPutCase p (PutCase name putter expecBs) = testCase name $ do let expecBc = coerce (length expecBs) actSink <- fmap (`asProxyTypeOf` p) (newSink expecBc) @@ -255,7 +282,6 @@ , 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) @@ -340,6 +366,7 @@ , GetCase "DoubleLE" getDoubleLE (Just (8, 0, DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D] , GetCase "DoubleBE" getDoubleBE (Just (8, 0, DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78] , GetCase "ShortByteString" (getByteString 2) (Just (2, 1, BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D, 0xBB] + , GetCase "Text" (getText 2) (Just (2, 1, "hi")) [0x68, 0x69, 0xBB] , GetCase "Two Word8" ((,) <$> getWord8 <*> getWord8) (Just (2, 0, (0x5D, 0xBB))) [0x5D, 0xBB] , GetCase "Two Word16LE" ((,) <$> getWord16LE <*> getWord16LE) (Just (4, 0, (0x5DEC, 0x4020))) [0xEC, 0x5D, 0x20, 0x40] , GetCase "Seq" (getSeq 2 getWord16LE) (Just (4, 0, Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40] @@ -349,7 +376,9 @@ , GetCase "StaFoo" (get @StaFoo) (Just (3, 0, StaFoo 0xBB 0x5DEC)) [0xBB, 0xEC, 0x5D] , GetCase "getRemainingSize" getRemainingSize (Just (0, 3, 3)) [0xBB, 0xEC, 0x5D] , GetCase "getSkip" (getSkip 2) (Just (2, 1, ())) [0xBB, 0xEC, 0x5D] - , GetCase "getLookAhead" (getLookAhead getWord16LE) (Just (0, 3, 0x5DEC)) [0xEC, 0x5D, 0xBB] + , GetCase "getLookAhead 0" (getLookAhead getWord16LE) (Just (0, 3, 0x5DEC)) [0xEC, 0x5D, 0xBB] + , GetCase "getLookAhead 1" (getWord8 >> getLookAhead getWord16LE) (Just (1, 2, 0xBB5D)) [0xEC, 0x5D, 0xBB] + , GetCase "getLookAhead 2" (getLookAhead (getWord8 >> getWord16LE)) (Just (0, 3, 0xBB5D)) [0xEC, 0x5D, 0xBB] , GetCase "getExact eq" (getExact 2 getWord16LE) (Just (2, 1, 0x5DEC)) [0xEC, 0x5D, 0xBB] , GetCase "getExact lt" (getExact 1 getWord16LE) Nothing [0xEC, 0x5D, 0xBB] , GetCase "getExact gt" (getExact 3 getWord16LE) Nothing [0xEC, 0x5D, 0xBB] @@ -363,9 +392,23 @@ , GetCase "StaBytes" (get @StaBytes) (Just (2, 1, mkStaBytes "hi")) [0x68, 0x69, 0x21] , GetCase "TagFoo (one)" (get @TagFoo) (Just (2, 0, TagFooOne 7)) [0x00, 0x07] , GetCase "TagFoo (two)" (get @TagFoo) (Just (3, 0, TagFooTwo 7)) [0x01, 0x07, 0x00] + , GetCase "TB8 0" (get @TermBytes8) (Just (1, 0, TermBytes8 BSS.empty)) [0] + , GetCase "TB8 1" (get @TermBytes8) (Just (2, 0, TermBytes8 (BSS.pack [1]))) [1, 0] + , GetCase "TB8 2" (get @TermBytes8) (Just (3, 0, TermBytes8 (BSS.pack [1, 2]))) [1, 2, 0] + , GetCase "TB8 3" (get @TermBytes8) (Just (4, 0, TermBytes8 (BSS.pack [1, 2, 3]))) [1, 2, 3, 0] + , GetCase "TB16 0" (get @TermBytes16) (Just (2, 0, TermBytes16 BSS.empty)) [0, 0] + , GetCase "TB16 1" (get @TermBytes16) (Just (2, 0, TermBytes16 (BSS.pack [1]))) [1, 0] + , GetCase "TB16 2" (get @TermBytes16) (Just (4, 0, TermBytes16 (BSS.pack [1, 2]))) [1, 2, 0, 0] + , GetCase "TB16 3" (get @TermBytes16) (Just (4, 0, TermBytes16 (BSS.pack [1, 2, 3]))) [1, 2, 3, 0] + , GetCase "Seq Word16LE" (get @(Seq Word16LE)) (Just (12, 0, Seq.fromList [0xEC, 0x5D])) [2, 0, 0, 0, 0, 0, 0, 0, 0xEC, 0, 0x5D, 0] + , GetCase + "Seq WordX" + (get @(Seq WordX)) + (Just (18, 0, Seq.fromList [WordX32 0, WordX32 0])) + [2, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 4, 0, 0, 0, 0] ] -testGet :: CaseTarget z => String -> Proxy z -> TestTree +testGet :: (BinaryGetTarget z IO, CaseTarget z) => String -> Proxy z -> TestTree testGet n p = testGroup ("get (" ++ n ++ ")") (fmap (runGetCase p) getCases) putCases :: [PutCase] @@ -393,6 +436,7 @@ , PutCase "DoubleLE" (putDoubleLE (DoubleLE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x78, 0x56, 0x34, 0x12, 0xFD, 0x6E, 0xEC, 0x5D] , PutCase "DoubleBE" (putDoubleBE (DoubleBE (castWord64ToDouble 0x5DEC6EFD12345678))) [0x5D, 0xEC, 0x6E, 0xFD, 0x12, 0x34, 0x56, 0x78] , PutCase "ShortByteString" (putByteString (BSS.pack [0xEC, 0x5D])) [0xEC, 0x5D] + , PutCase "Text" (putText "hi") [0x68, 0x69] , PutCase "Two Word8" (putWord8 0x5D *> putWord8 0xBB) [0x5D, 0xBB] , PutCase "Two Word16LE" (putWord16LE 0x5DEC *> putWord16LE 0x4020) [0xEC, 0x5D, 0x20, 0x40] , PutCase "Seq" (putSeq putWord16LE (Seq.fromList [0x5DEC, 0x4020])) [0xEC, 0x5D, 0x20, 0x40] @@ -409,9 +453,40 @@ , PutCase "StaBytes (more)" (put (mkStaBytes "hi!")) [0x68, 0x69] , PutCase "TagFoo (one)" (put (TagFooOne 7)) [0x00, 0x07] , PutCase "TagFoo (two)" (put (TagFooTwo 7)) [0x01, 0x07, 0x00] + , PutCase "TB8 0" (put (TermBytes8 BSS.empty)) [0] + , PutCase "TB8 1" (put (TermBytes8 (BSS.pack [1]))) [1, 0] + , PutCase "TB8 2" (put (TermBytes8 (BSS.pack [1, 2]))) [1, 2, 0] + , PutCase "TB8 3" (put (TermBytes8 (BSS.pack [1, 2, 3]))) [1, 2, 3, 0] + , PutCase "TB16 0" (put (TermBytes16 BSS.empty)) [0, 0] + , PutCase "TB16 1" (put (TermBytes16 (BSS.pack [1]))) [1, 0] + , PutCase "TB16 2" (put (TermBytes16 (BSS.pack [1, 2]))) [1, 2, 0, 0] + , PutCase "TB16 3" (put (TermBytes16 (BSS.pack [1, 2, 3]))) [1, 2, 3, 0] + , PutCase "Seq Word16LE" (put @(Seq Word16LE) (Seq.fromList [0xEC, 0x5D])) [2, 0, 0, 0, 0, 0, 0, 0, 0xEC, 0, 0x5D, 0] + , PutCase + "Seq WordX" + (put @(Seq WordX) (Seq.fromList [WordX32 0, WordX32 0])) + [ 2 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 0 + , 4 + , 0 + , 0 + , 0 + , 0 + ] ] -testPut :: CaseTarget z => String -> Proxy z -> TestTree +testPut :: (BinaryPutTarget z IO, CaseTarget z) => String -> Proxy z -> TestTree testPut n p = testGroup ("put (" ++ n ++ ")") (fmap (runPutCase p) putCases) testLiftedPrimArray :: TestTree @@ -421,24 +496,109 @@ sizeofLiftedPrimArray arr @?= 6 lengthLiftedPrimArray arr @?= 3 -testGetOffset :: CaseTarget z => String -> Proxy z -> TestTree +testGetOffset :: (BinaryGetTarget z IO, CaseTarget z) => String -> Proxy z -> TestTree testGetOffset n p = testCase ("get offset (" ++ n ++ ")") $ do let buf = [0x12, 0x34, 0x56, 0x78] - src = initSource buf `asProxyTypeOf` p - (ez1, c1) = getTargetOffset 0 getWord8 src + src <- initSource buf + (ez1, c1) <- getTargetOffset 0 getWord8 (src `asProxyTypeOf` p) ez1 @?= Right 0x12 c1 @?= 1 - let (ez2, c2) = getTargetOffset 1 getWord16LE src + (ez2, c2) <- getTargetOffset 1 getWord16LE src ez2 @?= Right 0x5634 c2 @?= 3 - let (ez3, c3) = getTargetOffset 3 getWord16LE src - ez3 @?= Left (GetErrorParseNeed "Word16LE" 1 2) + (ez3, c3) <- getTargetOffset 3 getWord16LE src + ez3 @?= Left (GetErrorGlobalCap "Word16LE" 1 2) c3 @?= 3 -testMutPut :: MutCaseTarget u => String -> Proxy u -> TestTree +data WordX + = WordX8 !Word8 + | WordX16 !Word16LE + | WordX32 !Word32LE + deriving stock (Eq, Ord, Show) + +instance Binary WordX where + byteSize = + succ . \case + WordX8 _ -> 1 + WordX16 _ -> 2 + WordX32 _ -> 4 + get = do + w <- get @Word8 + case w of + 1 -> fmap WordX8 get + 2 -> fmap WordX16 get + 4 -> fmap WordX32 get + _ -> fail ("Bad size for WordX: " ++ show w) + put = \case + WordX8 w -> put @Word8 1 >> put w + WordX16 w -> put @Word8 2 >> put w + WordX32 w -> put @Word8 4 >> put w + +wordXGen :: Gen WordX +wordXGen = FG.choose gen8 (FG.choose gen16 gen32) + where + gen8 = fmap WordX8 (FG.inRange (FR.between (0, maxBound))) + gen16 = fmap (WordX16 . Word16LE) (FG.inRange (FR.between (0, maxBound))) + gen32 = fmap (WordX32 . Word32LE) (FG.inRange (FR.between (0, maxBound))) + +takeDiff :: (CaseTarget z) => z -> ByteCount -> ByteCount -> ByteCount -> [ByteCount] -> IO ([ByteCount], (ByteCount, z)) +takeDiff z pos had diff = go 0 + where + go !acc = \case + y : ys | acc < diff -> go (acc + y) ys + ys -> do + zz <- sliceBuffer z pos (had + acc) + pure (ys, (acc, zz)) + +assertEq :: (Eq a, Show a) => a -> a -> Property () +assertEq x y = FP.assert (FC.eq FC..$ ("LHS", x) FC..$ ("RHS", y)) + +hackLiftIO :: IO a -> Property a +hackLiftIO = pure . unsafePerformIO + +testGetInc :: (BinaryPutTarget z IO, CaseTarget z) => String -> Proxy z -> TestTree +testGetInc n p = testProperty ("get inc (" ++ n ++ ")") $ do + -- Generate some random elements + numElems <- FP.gen @Int (FG.inRange (FR.between (0, 20))) + xs <- FP.gen (replicateM numElems wordXGen) + -- First some sanity checks that encode/decode work + assertEq (length xs) numElems + wholeBuf <- hackLiftIO (encode xs) + (exs, totLen) <- hackLiftIO (decodeEnd (wholeBuf `asProxyTypeOf` p)) + case exs of + Left err -> fail (show err) + Right xs' -> do + assertEq xs' xs + assertEq totLen (byteSize xs) + wholeBuf' <- hackLiftIO (sliceBuffer wholeBuf 0 totLen) + assertEq wholeBuf' wholeBuf + -- Shuffle list to come up with splits and test incremental + ys <- FP.gen (FG.shuffle (8 : fmap byteSize xs)) + ysRef <- hackLiftIO (newIORef ys) + sentRef <- hackLiftIO (newIORef 0) + let cb (GetIncRequest pos _ len) = do + sent <- readIORef sentRef + let had = sent - pos + let diff = len - had + ys' <- readIORef ysRef + (ys'', (bufLen, buf)) <- takeDiff wholeBuf pos had diff ys' + writeIORef ysRef ys'' + modifyIORef' sentRef (+ bufLen) + pure $ + if bufLen == 0 + then Nothing + else Just (buf `asProxyTypeOf` p) + (ezs, totLen', _) <- hackLiftIO (decodeInc (Just totLen) cb) + case ezs of + Left err -> fail (show err) + Right zs -> do + assertEq zs xs + assertEq totLen' totLen + +testMutPut :: (MutBinaryPutTarget z IO, MutCaseTarget z) => String -> Proxy z -> TestTree testMutPut n p = testGroup ("mut put (" ++ n ++ ")") (fmap (mutRunPutCase p) putCases) -testMutPutOffset :: MutCaseTarget u => String -> Proxy u -> TestTree +testMutPutOffset :: (MutBinaryPutTarget z IO, MutCaseTarget z) => String -> Proxy z -> TestTree testMutPutOffset n p = testCase ("mut put offset (" ++ n ++ ")") $ do u <- newSink 4 c1 <- mutPutTargetOffset 0 (putWord8 0x12) u @@ -446,11 +606,20 @@ c2 <- mutPutTargetOffset 1 (putWord16LE 0x5634) u c2 @?= 3 x <- freezeSink (u `asProxyTypeOf` p) - x @?= [0x12, 0x34, 0x56, 0] - pure () + take 3 x @?= [0x12, 0x34, 0x56] + -- Use this opportunity to test getting + (w, h) <- getTarget (liftA2 (,) (get @Word8) (get @Word16LE)) u + w @?= Right (0x12, 0x5634) + h @?= 3 + (y, i) <- getTargetOffset 0 (get @Word8) u + y @?= Right 0x12 + i @?= 1 + (z, j) <- getTargetOffset 1 (get @Word16LE) u + z @?= Right 0x5634 + j @?= 3 data TargetDef where - TargetDef :: CaseTarget z => String -> Proxy z -> TargetDef + TargetDef :: (BinaryPutTarget z IO, CaseTarget z) => String -> Proxy z -> TargetDef targets :: [TargetDef] targets = @@ -460,12 +629,12 @@ ] data MutTargetDef where - MutTargetDef :: MutCaseTarget u => String -> Proxy u -> MutTargetDef + MutTargetDef :: (MutBinaryPutTarget z IO, MutCaseTarget z) => String -> Proxy z -> MutTargetDef mutTargets :: [MutTargetDef] mutTargets = - [ MutTargetDef "MutableByteArray" (Proxy :: Proxy (MutableByteArray (PrimState IO))) - , MutTargetDef "MVector" (Proxy :: Proxy (MVector (PrimState IO) Word8)) + [ MutTargetDef "MutableByteArray" (Proxy :: Proxy (MutableByteArray RealWorld)) + , MutTargetDef "IOVector" (Proxy :: Proxy (IOVector Word8)) ] testDahdit :: TestTree @@ -476,8 +645,9 @@ targetTrees = targets >>= \(TargetDef name prox) -> [ testGet name prox - , testPut name prox , testGetOffset name prox + , testGetInc name prox + , testPut name prox ] mutTargetTrees = mutTargets >>= \(MutTargetDef name prox) ->