diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.6.0 (2024-04-05) +* many updates to parsing/serializing internals, including generics +* provide "C struct" serializer + ## 0.5.0 (2023-08-17) * support GHC 9.2 - 9.6 * extract generic serializing & parsing into separate library. yes, I wrote diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -29,8 +29,8 @@ | X33 Word8 (NullTerminated B.ByteString) X3 deriving stock (Generic) -instance BLen X3 where blen = blenGenericSum cDef -instance Put X3 where put = putGenericSum cDef +instance BLen X3 where blen = blenGenericSum $ blen . nullTermCstrPfxTag +instance Put X3 where put = putGenericSum $ put . nullTermCstrPfxTag x33 :: X3 x33 = diff --git a/binrep.cabal b/binrep.cabal --- a/binrep.cabal +++ b/binrep.cabal @@ -5,10 +5,10 @@ -- see: https://github.com/sol/hpack name: binrep -version: 0.5.0 +version: 0.6.0 synopsis: Encode precise binary representations directly in types description: Please see README.md. -category: Data, Serialization +category: Data, Serialization, Generics homepage: https://github.com/raehik/binrep#readme bug-reports: https://github.com/raehik/binrep/issues author: Ben Orchard @@ -34,21 +34,19 @@ library exposed-modules: Binrep - Binrep.BLen.Simple + Binrep.BLen Binrep.CBLen Binrep.CBLen.Generic - Binrep.Extra.HexByteString + Binrep.Common.Class.TypeErrors + Binrep.Common.Via.Prim Binrep.Generic - Binrep.Get.Flatparse - Binrep.Put.Bytezap - Binrep.Put.Mason - Binrep.Type.Byte - Binrep.Type.Common - Binrep.Type.Int + Binrep.Get + Binrep.Put + Binrep.Put.Struct + Binrep.Test Binrep.Type.Magic Binrep.Type.NullPadded Binrep.Type.NullTerminated - Binrep.Type.Prefix Binrep.Type.Prefix.Count Binrep.Type.Prefix.Size Binrep.Type.Sized @@ -61,17 +59,11 @@ Binrep.Type.Text.Internal Binrep.Type.Thin Binrep.Util - Binrep.Util.Class + Binrep.Util.ByteOrder Binrep.Util.Generic - Binrep.Via - Bytezap - Bytezap.Bytes - Bytezap.Class - Bytezap.Int - Bytezap.Poke.Bytes - Bytezap.Poke.Int - Bytezap.Text - Data.Aeson.Extra.SizedVector + Binrep.Util.Prefix + Raehik.Compat.FlatParse.Basic.Prim + Raehik.Compat.FlatParse.Basic.WithLength Util.TypeNats other-modules: Paths_binrep @@ -90,20 +82,17 @@ MagicHash ghc-options: -Wall build-depends: - aeson >=2.0 && <2.2 - , base >=4.14 && <5 + base >=4.14 && <5 , bytestring >=0.11 && <0.13 + , bytezap >=1.1.0 && <1.2 , deepseq >=1.4.6.1 && <1.6 - , flatparse >=0.4.0.1 && <0.6 - , generic-data-functions >=0.2.0 && <0.3 - , mason >=0.2.5 && <0.3 - , megaparsec >=9.2.0 && <9.5.0 + , flatparse >=0.5.0.2 && <0.6 + , generic-data-asserts >=0.1.0 && <0.2 + , generic-data-functions >=0.4.1 && <0.5 , parser-combinators >=1.3.0 && <1.4 , refined1 ==0.9.* , strongweak >=0.6.0 && <0.7 , text >=1.2.5.0 && <2.1 - , vector >=0.12.3.1 && <0.14 - , vector-sized >=1.5.0 && <1.6 default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU @@ -115,7 +104,6 @@ main-is: Spec.hs other-modules: ArbitraryOrphans - Binrep.Extra.HexByteStringSpec Binrep.LawsSpec Paths_binrep hs-source-dirs: @@ -136,24 +124,21 @@ hspec-discover:hspec-discover >=2.7 && <2.12 build-depends: QuickCheck >=2.14.2 && <2.15 - , aeson >=2.0 && <2.2 , base >=4.14 && <5 , binrep , bytestring >=0.11 && <0.13 + , bytezap >=1.1.0 && <1.2 , deepseq >=1.4.6.1 && <1.6 - , flatparse >=0.4.0.1 && <0.6 - , generic-data-functions >=0.2.0 && <0.3 + , flatparse >=0.5.0.2 && <0.6 + , generic-data-asserts >=0.1.0 && <0.2 + , generic-data-functions >=0.4.1 && <0.5 , generic-random >=1.5.0.1 && <1.6 , hspec >=2.7 && <2.12 - , mason >=0.2.5 && <0.3 - , megaparsec >=9.2.0 && <9.5.0 , parser-combinators >=1.3.0 && <1.4 , quickcheck-instances >=0.3.26 && <0.4 , refined1 ==0.9.* , strongweak >=0.6.0 && <0.7 , text >=1.2.5.0 && <2.1 - , vector >=0.12.3.1 && <0.14 - , vector-sized >=1.5.0 && <1.6 default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU @@ -178,24 +163,21 @@ TypeFamilies DataKinds MagicHash - ghc-options: -Wall -O2 + ghc-options: -Wall build-depends: - aeson >=2.0 && <2.2 - , base >=4.14 && <5 + base >=4.14 && <5 , binrep , bytestring >=0.11 && <0.13 + , bytezap >=1.1.0 && <1.2 , deepseq >=1.4.6.1 && <1.6 - , flatparse >=0.4.0.1 && <0.6 + , flatparse >=0.5.0.2 && <0.6 , gauge - , generic-data-functions >=0.2.0 && <0.3 - , mason >=0.2.5 && <0.3 - , megaparsec >=9.2.0 && <9.5.0 + , generic-data-asserts >=0.1.0 && <0.2 + , generic-data-functions >=0.4.1 && <0.5 , parser-combinators >=1.3.0 && <1.4 , refined1 ==0.9.* , strongweak >=0.6.0 && <0.7 , text >=1.2.5.0 && <2.1 - , vector >=0.12.3.1 && <0.14 - , vector-sized >=1.5.0 && <1.6 default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU diff --git a/src/Binrep.hs b/src/Binrep.hs --- a/src/Binrep.hs +++ b/src/Binrep.hs @@ -1,14 +1,16 @@ module Binrep - ( module Binrep.CBLen - , module Binrep.BLen.Simple - , module Binrep.Put.Bytezap - , module Binrep.Get.Flatparse + ( module Binrep.BLen + , module Binrep.CBLen + , module Binrep.Put + , module Binrep.Put.Struct + , module Binrep.Get ) where +import Binrep.BLen import Binrep.CBLen -import Binrep.BLen.Simple -import Binrep.Put.Bytezap -import Binrep.Get.Flatparse +import Binrep.Put +import Binrep.Put.Struct +import Binrep.Get {- TODO * binrep is its own ecosystem where explicitness and correctness wins over diff --git a/src/Binrep/BLen.hs b/src/Binrep/BLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/BLen.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE UndecidableInstances #-} -- for 'ViaCBLen', 'TypeError' + +{- | Byte length as a simple pure function, no bells or whistles. + +Non-reallocating serializers like store, bytezap or ptr-poker request the +expected total byte length when serializing. Thus, they need some way to measure +byte length *before* serializing. This is that. + +It should be very efficient to calculate serialized byte length for most +binrep-compatible Haskell types. If it isn't, consider whether the +representation is appropriate for binrep. + +Note that you _may_ encode this inside the serializer type (whatever the @Put@ +class stores). I went back and forth on this a couple times. But some binrep +code seems to make more sense when byte length is standalone. And I don't mind +the extra explicitness. So it's here to stay :) +-} + +module Binrep.BLen + ( BLen(blen) + , blenGenericNonSum, blenGenericSum + , ViaCBLen(..), cblen + ) where + +import Binrep.CBLen +import GHC.TypeNats + +import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty ) +import GHC.TypeLits ( TypeError ) + +import Data.Void +import Data.ByteString qualified as B +import Data.Word +import Data.Int +import Binrep.Util.ByteOrder + +import Data.Monoid qualified as Monoid +import GHC.Generics +import Generic.Data.Function.FoldMap +import Generic.Data.Rep.Assert +import Generic.Data.Function.Common + +-- | Class for types with easily-calculated length in bytes. +-- +-- If it appears hard to calculate byte length for a given type (e.g. without +-- first serializing it, then measuring serialized byte length), consider +-- whether this type is a good fit for binrep. +class BLen a where + -- | Calculate the serialized byte length of the given value. + blen :: a -> Int + +instance GenericFoldMap BLen where + type GenericFoldMapM BLen = Monoid.Sum Int + type GenericFoldMapC BLen a = BLen a + genericFoldMapF = Monoid.Sum . blen + +-- | Measure the byte length of a term of the non-sum type @a@ via its 'Generic' +-- instance. +blenGenericNonSum + :: forall a + . ( Generic a, GFoldMapNonSum BLen (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => a -> Int +blenGenericNonSum = Monoid.getSum . genericFoldMapNonSum @BLen + +-- | Measure the byte length of a term of the sum type @a@ via its 'Generic' +-- instance. +-- +-- You must provide a function to obtain the byte length for the prefix tag, via +-- inspecting the reified constructor names. This is regrettably inefficient. +-- Alas. Do write your own instance if you want better performance! +blenGenericSum + :: forall a + . ( Generic a, GFoldMapSum BLen 'SumOnly (Rep a) + , GAssertNotVoid a, GAssertSum a + ) => (String -> Int) -> a -> Int +blenGenericSum f = + Monoid.getSum . genericFoldMapSum @BLen @'SumOnly (Monoid.Sum <$> f) + +instance TypeError ENoEmpty => BLen Void where blen = undefined +instance TypeError ENoSum => BLen (Either a b) where blen = undefined + +-- | _O(1)_ Unit type has length 0. +instance BLen () where blen () = 0 + +-- | _O(1)_ Sum tuples. +instance (BLen l, BLen r) => BLen (l, r) where blen (l, r) = blen l + blen r + +-- | _O(n)_ Sum the length of each element of a list. +instance BLen a => BLen [a] where blen = sum . map blen + +-- | _O(1)_ 'B.ByteString's store their own length. +instance BLen B.ByteString where blen = B.length + +-- All words have a constant byte length-- including host-size words, mind you! +deriving via ViaCBLen Word8 instance BLen Word8 +deriving via ViaCBLen Int8 instance BLen Int8 +deriving via ViaCBLen Word16 instance BLen Word16 +deriving via ViaCBLen Int16 instance BLen Int16 +deriving via ViaCBLen Word32 instance BLen Word32 +deriving via ViaCBLen Int32 instance BLen Int32 +deriving via ViaCBLen Word64 instance BLen Word64 +deriving via ViaCBLen Int64 instance BLen Int64 +deriving via ViaCBLen (ByteOrdered end a) + instance KnownNat (CBLen a) => BLen (ByteOrdered end a) + +-------------------------------------------------------------------------------- + +-- | DerivingVia wrapper for types which may derive a 'BLen' instance through +-- an existing 'IsCBLen' instance (i.e. it is known at compile time) +-- +-- Examples of such types include machine integers, and explicitly-sized types +-- (e.g. "Binrep.Type.Sized"). +newtype ViaCBLen a = ViaCBLen { unViaCBLen :: a } +instance KnownNat (CBLen a) => BLen (ViaCBLen a) where blen _ = cblen @a diff --git a/src/Binrep/BLen/Simple.hs b/src/Binrep/BLen/Simple.hs deleted file mode 100644 --- a/src/Binrep/BLen/Simple.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- for 'CBLenly', 'TypeError' -{-# LANGUAGE AllowAmbiguousTypes #-} -- for 'cblen', 'natValInt' - -{- | Byte length as a simple pure function, no bells or whistles. - -Non-reallocating serializers like store, bytezap or ptr-poker request the -expected total byte length when serializing. Thus, they need some way to measure -byte length *before* serializing. This is that. - -It should be very efficient to calculate serialized byte length for most -binrep-compatible Haskell types. If it isn't, consider whether the -representation is appropriate for binrep. --} - -module Binrep.BLen.Simple where - -import Binrep.CBLen -import GHC.TypeNats -import Util.TypeNats ( natValInt ) - -import Binrep.Util.Class -import GHC.TypeLits ( TypeError ) - -import Data.Void -import Data.ByteString qualified as B -import Data.Word -import Data.Int -import Bytezap ( Write(..) ) - -import Data.Monoid ( Sum(..) ) -import GHC.Generics -import Generic.Data.Function.FoldMap -import Generic.Data.Rep.Assert -import Generic.Data.Function.Common - -class BLen a where blen :: a -> Int - --- newtype sum monoid for generic foldMap -newtype BLen' a = BLen' { getBLen' :: a } - deriving (Semigroup, Monoid) via Sum a - -instance GenericFoldMap (BLen' Int) where - type GenericFoldMapC (BLen' Int) a = BLen a - genericFoldMapF = BLen' . blen - --- | Measure the byte length of a term of the non-sum type @a@ via its 'Generic' --- instance. -blenGenericNonSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum (BLen' Int) f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) - => a -> Int -blenGenericNonSum = getBLen' . genericFoldMapNonSum @asserts - --- | Measure the byte length of a term of the sum type @a@ via its 'Generic' --- instance. --- --- You must provide a function to obtain the byte length for the prefix tag, via --- inspecting the reified constructor names. This is regrettably inefficient. --- Alas. Do write your own instance if you want better performance! -blenGenericSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly (BLen' Int) f - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) - => (String -> Int) -> a -> Int -blenGenericSum f = getBLen' . genericFoldMapSum @'SumOnly @asserts (BLen' <$> f) - -instance TypeError ENoEmpty => BLen Void where blen = undefined -instance TypeError ENoSum => BLen (Either a b) where blen = undefined - -instance BLen Write where - {-# INLINE blen #-} - blen = writeSize - --- | Unit type has length 0. -instance BLen () where - {-# INLINE blen #-} - blen () = 0 - --- | Sum tuples. -instance (BLen l, BLen r) => BLen (l, r) where - {-# INLINE blen #-} - blen (l, r) = blen l + blen r - --- | _O(n)_ Sum the length of each element of a list. -instance BLen a => BLen [a] where - {-# INLINE blen #-} - blen = sum . map blen - --- | Length of a bytestring is fairly obvious. -instance BLen B.ByteString where - {-# INLINE blen #-} - blen = B.length - --- Machine integers have a constant byte length. -deriving via CBLenly Word8 instance BLen Word8 -deriving via CBLenly Int8 instance BLen Int8 -deriving via CBLenly Word16 instance BLen Word16 -deriving via CBLenly Int16 instance BLen Int16 -deriving via CBLenly Word32 instance BLen Word32 -deriving via CBLenly Int32 instance BLen Int32 -deriving via CBLenly Word64 instance BLen Word64 -deriving via CBLenly Int64 instance BLen Int64 - --------------------------------------------------------------------------------- - --- | Deriving via wrapper for types which may derive a 'BLen' instance through --- an existing 'IsCBLen' instance. --- --- Examples of such types include machine integers, and explicitly-sized types --- (e.g. "Binrep.Type.Sized"). -newtype CBLenly a = CBLenly { unCBLenly :: a } -instance KnownNat (CBLen a) => BLen (CBLenly a) where - {-# INLINE blen #-} - blen _ = cblen @a - --- | Reify a type's constant byte length to the term level. -cblen :: forall a n. (n ~ CBLen a, KnownNat n) => Int -cblen = natValInt @n -{-# INLINE cblen #-} diff --git a/src/Binrep/CBLen.hs b/src/Binrep/CBLen.hs --- a/src/Binrep/CBLen.hs +++ b/src/Binrep/CBLen.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE UndecidableInstances #-} -- for 'WithCBLen' -{-# LANGUAGE AllowAmbiguousTypes #-} -- for 'cblen' +{-# LANGUAGE UndecidableInstances #-} -- for nested type families +{-# LANGUAGE AllowAmbiguousTypes #-} -- for reification util module Binrep.CBLen where import GHC.TypeNats import Data.Word import Data.Int +import Binrep.Util.ByteOrder +import GHC.Exts ( Int#, Int(I#), Proxy# ) +import Util.TypeNats ( natValInt ) + class IsCBLen a where type CBLen a :: Natural instance IsCBLen () where type CBLen () = 0 @@ -21,3 +25,18 @@ instance IsCBLen Int32 where type CBLen Int32 = 2^2 instance IsCBLen Word64 where type CBLen Word64 = 2^3 instance IsCBLen Int64 where type CBLen Int64 = 2^3 + +instance IsCBLen a => IsCBLen (ByteOrdered end a) where + type CBLen (ByteOrdered end a) = CBLen a + +-- | Reify a type's constant byte length to the term level. +cblen :: forall a. KnownNat (CBLen a) => Int +cblen = natValInt @(CBLen a) + +cblen# :: forall a. KnownNat (CBLen a) => Int# +cblen# = i# + where !(I# i#) = natValInt @(CBLen a) + +cblenProxy# :: forall a. KnownNat (CBLen a) => Proxy# a -> Int# +cblenProxy# _ = i# + where !(I# i#) = natValInt @(CBLen a) diff --git a/src/Binrep/CBLen/Generic.hs b/src/Binrep/CBLen/Generic.hs --- a/src/Binrep/CBLen/Generic.hs +++ b/src/Binrep/CBLen/Generic.hs @@ -14,7 +14,7 @@ You can (attempt to) derive a 'CBLen' type family instance generically for a type via - instance BLen a where type CBLen a = CBLenGeneric w a + instance IsCBLen a where type CBLen a = CBLenGeneric w a As with deriving @BLen@ generically, you must provide the type used to store the sum tag for sum types. @@ -26,7 +26,7 @@ module Binrep.CBLen.Generic where import Binrep.CBLen -import Binrep.Util.Class +import Binrep.Common.Class.TypeErrors ( ENoEmpty ) import GHC.Generics import GHC.TypeLits @@ -34,6 +34,8 @@ import Data.Type.Equality import Data.Type.Bool + +-- TODO provide non-sum version type CBLenGeneric w a = GCBLen w (Rep a) diff --git a/src/Binrep/Common/Class/TypeErrors.hs b/src/Binrep/Common/Class/TypeErrors.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Class/TypeErrors.hs @@ -0,0 +1,19 @@ +module Binrep.Common.Class.TypeErrors where + +import GHC.TypeLits + +-- | Common type error string for when you attempt to use a binrep instance at +-- an empty data type (e.g. 'Data.Void.Void', 'GHC.Generics.V1'). +type ENoEmpty = 'Text "No binary representation for empty data type" + +-- | Common type error string for when you attempt to use a binrep instance +-- at a sum data type +-- GHC is asked to derive a non-sum +-- instance, but the data type in question turns out to be a sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type ENoSum = + 'Text "No binary representation for unannotated sum data type" + :$$: 'Text "Consider defining a custom data type" + :<>: 'Text " and deriving a generic instance with explicit sum handling" diff --git a/src/Binrep/Common/Via/Prim.hs b/src/Binrep/Common/Via/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Via/Prim.hs @@ -0,0 +1,4 @@ +module Binrep.Common.Via.Prim where + +-- | DerivingVia newtype for types which can borrow from 'Prim''. +newtype ViaPrim a = ViaPrim { unViaPrim :: a } diff --git a/src/Binrep/Extra/HexByteString.hs b/src/Binrep/Extra/HexByteString.hs deleted file mode 100644 --- a/src/Binrep/Extra/HexByteString.hs +++ /dev/null @@ -1,109 +0,0 @@ --- | Pretty bytestrings via printing each byte as two hex digits. --- --- This is primarily for aeson and when we want better 'show'ing of non-textual --- bytestrings. It's not really binrep-related, but it needs _somewhere_ to go --- and my projects that need it usually also touch binrep, so here it is. --- --- Sadly, we can't use it to make aeson print integers as hex literals. It only --- deals in Scientifics, and if we tried printing them as strings, it would --- quote them. I need a YAML-like with better literals... - -module Binrep.Extra.HexByteString where - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -import Data.ByteString qualified as B -import Data.ByteString.Short qualified as B.Short -import Data.Char qualified as Char -import Data.Word -import Data.Text qualified as Text -import Data.Text ( Text ) -import Data.List as List - -import Text.Megaparsec hiding ( parse ) -import Text.Megaparsec.Char qualified as MC -import Data.Void - -import Data.Aeson - --- TODO could add some integer instances to print them as hex too - --- No harm in being polymorphic over the byte representation. -newtype Hex a = Hex { unHex :: a } - deriving stock (Generic, Data) - deriving Eq via a - --- But most users will probably just want this. -type HexByteString = Hex B.ByteString - -instance Show (Hex B.ByteString) where - show = Text.unpack . prettyHexByteString B.unpack . unHex - -instance FromJSON (Hex B.ByteString) where - parseJSON = withText "hex bytestring" $ \t -> - case parseMaybe @Void (parseHexByteString B.pack) t of - Nothing -> fail "failed to parse hex bytestring (TODO)" - Just t' -> pure (Hex t') - -instance ToJSON (Hex B.ByteString) where - toJSON = String . prettyHexByteString B.unpack . unHex - -instance Show (Hex B.Short.ShortByteString) where - show = Text.unpack . prettyHexByteString B.Short.unpack . unHex - -instance FromJSON (Hex B.Short.ShortByteString) where - parseJSON = withText "hex bytestring" $ \t -> - case parseMaybe @Void (parseHexByteString B.Short.pack) t of - Nothing -> fail "failed to parse hex bytestring (TODO)" - Just t' -> pure (Hex t') - -instance ToJSON (Hex B.Short.ShortByteString) where - toJSON = String . prettyHexByteString B.Short.unpack . unHex - --- | A hex bytestring looks like this: @00 01 89 8a FEff@. You can mix and --- match capitalization and spacing, but I prefer to space each byte, full caps. -parseHexByteString - :: (MonadParsec e s m, Token s ~ Char) - => ([Word8] -> a) -> m a -parseHexByteString pack = pack <$> parseHexByte `sepBy` MC.hspace - --- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both --- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid. --- --- Returns a value 0-255, so can fit in any Num type that can store that. -parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a -parseHexByte = do - c1 <- MC.hexDigitChar - c2 <- MC.hexDigitChar - pure $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2) - --- | Pretty print to default format @00 12 AB FF@: space between each byte, all --- caps. --- --- This format I consider most human readable. I prefer caps to draw attention --- to this being data instead of text (you don't see that many capital letters --- packed together in prose). -prettyHexByteString :: (a -> [Word8]) -> a -> Text -prettyHexByteString unpack = - Text.concat - . List.intersperse (Text.singleton ' ') - . fmap (f . prettyHexByte Char.toUpper) - . unpack - where - f :: (Char, Char) -> Text - f (c1, c2) = Text.cons c1 $ Text.singleton c2 - -prettyHexByte :: (Char -> Char) -> Word8 -> (Char, Char) -prettyHexByte f w = (prettyNibble h, prettyNibble l) - where - (h,l) = fromIntegral w `divMod` 0x10 - prettyNibble = f . Char.intToDigit -- Char.intToDigit returns lower case - --- | Pretty print to "compact" format @0012abff@ (often output by hashers). -prettyHexByteStringCompact :: (a -> [Word8]) -> a -> Text -prettyHexByteStringCompact unpack = - Text.concat . fmap (f . prettyHexByte id) . unpack - where - f :: (Char, Char) -> Text - f (c1, c2) = Text.cons c1 $ Text.singleton c2 diff --git a/src/Binrep/Generic.hs b/src/Binrep/Generic.hs --- a/src/Binrep/Generic.hs +++ b/src/Binrep/Generic.hs @@ -9,8 +9,7 @@ -- | Turn a constructor name into a prefix tag by adding a null terminator. -- -- Not common in binary data representations, but safe and useful for debugging. --- --- The refine force is safe under the assumption that Haskell constructor names --- are UTF-8 with no null bytes allowed. Fairly certain that's true. nullTermCstrPfxTag :: String -> NullTerminated B.ByteString nullTermCstrPfxTag = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack +-- ^ reallyUnsafeRefine : safe assuming Haskell constructor names are UTF-8 with +-- no null bytes allowed diff --git a/src/Binrep/Get.hs b/src/Binrep/Get.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Get.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 +{-# LANGUAGE BlockArguments #-} + +module Binrep.Get + ( Getter, Get(..), runGet, runGetter + , E(..), EBase(..), EGeneric(..), EGenericSum(..) + , eBase + , getEBase + -- , GetWith(..), runGetWith + , getPrim + , getGenericNonSum, getGenericSum + ) where + +import Data.Functor.Identity +import Binrep.Util.ByteOrder +import Binrep.Common.Via.Prim ( ViaPrim(..) ) +import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf ) +import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap ) + +import FlatParse.Basic qualified as FP +import Raehik.Compat.FlatParse.Basic.Prim qualified as FP + +import Data.ByteString qualified as B + +import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty ) +import GHC.TypeLits ( TypeError ) + +import Data.Void +import Data.Word +import Data.Int + +import Data.Text ( Text ) + +import Numeric.Natural + +import GHC.Generics +import Generic.Data.Function.Traverse +import Generic.Data.Function.Common +import Generic.Data.Rep.Assert + +import GHC.Exts ( minusAddr#, Int(I#) ) + +type Getter a = FP.Parser E a + +-- | Structured parse error. +data E + = E Int EMiddle + + -- | Unhandled parse error. + -- + -- You get this if you don't change a flatparse fail to an error. + -- + -- Should not be set except by library code. + | EFail + + deriving stock (Eq, Show, Generic) + +data EMiddle + + -- | Parse error with no further context. + = EBase EBase + + -- | Somehow, we got two parse errors. + -- + -- I have a feeling that seeing this indicates a problem in your code. + | EAnd E EBase + + -- | Parse error decorated with generic info. + -- + -- Should not be set except by library code. + | EGeneric String {- ^ data type name -} (EGeneric E) + + deriving stock (Eq, Show, Generic) + +data EBase + = EExpectedByte Word8 Word8 + -- ^ expected first, got second + + | EOverlong Int Int + -- ^ expected first, got second + + | EExpected B.ByteString B.ByteString + -- ^ expected first, got second + + | EFailNamed String + -- ^ known fail + + | EFailParse String B.ByteString Word8 + -- ^ parse fail (where you parse a larger object, then a smaller one in it) + + | ERanOut Int + -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0) + -- + -- Actually a 'Natural', but we use 'Int' because that's what flatparse uses + -- internally. + + deriving stock (Eq, Show, Generic) + +-- | A generic context layer for a parse error of type @e@. +-- +-- Recursive: parse errors occurring in fields are wrapped up here. (Those +-- errors may also have a generic context layer.) +-- +-- Making this explicitly recursive may seem strange, but it clarifies that this +-- data type is to be seen as a layer over a top-level type. +data EGeneric e + -- | Parse error relating to sum types (constructors). + = EGenericSum (EGenericSum e) + + -- | Parse error in a constructor field. + | EGenericField + String -- ^ constructor name + (Maybe String) -- ^ field record name (if present) + Natural -- ^ field index in constructor + e -- ^ field parse error + deriving stock (Eq, Show, Generic) + +data EGenericSum e + -- | Parse error parsing prefix tag. + = EGenericSumTag e + + -- | Unable to match a constructor to the parsed prefix tag. + | EGenericSumTagNoMatch + [String] -- ^ constructors tested + Text -- ^ prettified prefix tag + deriving stock (Eq, Show, Generic) + +eBase :: EBase -> Getter a +eBase eb = FP.ParserT \_fp eob s st -> + let os = I# (minusAddr# eob s) + in FP.Err# st (E os $ EBase eb) + +getEBase :: Getter a -> EBase -> Getter a +getEBase (FP.ParserT f) eb = + FP.ParserT \fp eob s st -> + let os = I# (minusAddr# eob s) + in case f fp eob s st of + FP.Fail# st' -> FP.Err# st' (E os $ EBase eb) + FP.Err# st' e -> FP.Err# st' (E os $ EAnd e eb) + x -> x + +-- | Parse. On parse error, coat it in a generic context layer. +getWrapGeneric :: Get a => String -> (E -> EGeneric E) -> Getter a +getWrapGeneric = getWrapGeneric' get + +getWrapGeneric' :: Getter a -> String -> (E -> EGeneric E) -> Getter a +getWrapGeneric' (FP.ParserT f) cd fe = + FP.ParserT \fp eob s st -> + let os = I# (minusAddr# eob s) + in case f fp eob s st of + FP.Fail# st' -> FP.Err# st' (E os $ EGeneric cd $ fe EFail) + FP.Err# st' e -> FP.Err# st' (E os $ EGeneric cd $ fe e) + x -> x + +class Get a where + -- | Parse from binary. + get :: Getter a + +runGet :: Get a => B.ByteString -> Either E (a, B.ByteString) +runGet = runGetter get + +runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString) +runGetter g bs = case FP.runParser g bs of + FP.OK a bs' -> Right (a, bs') + FP.Fail -> Left EFail + FP.Err e -> Left e + +instance GenericTraverse Get where + type GenericTraverseF Get = FP.Parser E + type GenericTraverseC Get a = Get a + genericTraverseAction cd cc mcs si = + getWrapGeneric cd $ EGenericField cc mcs si + +instance GenericTraverseSum Get where + genericTraverseSumPfxTagAction cd = + getWrapGeneric cd $ EGenericSum . EGenericSumTag + -- TODO proper offset info + genericTraverseSumNoMatchingCstrAction cd cstrs ptText = + FP.err $ E 0 $ EGeneric cd $ EGenericSum $ EGenericSumTagNoMatch cstrs ptText + +getGenericNonSum + :: forall a + . (Generic a, GTraverseNonSum Get (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => Getter a +getGenericNonSum = genericTraverseNonSum @Get + +getGenericSum + :: forall pt a + . ( Generic a, GTraverseSum Get 'SumOnly (Rep a) + , Get pt + , GAssertNotVoid a, GAssertSum a + ) => PfxTagCfg pt -> Getter a +getGenericSum = genericTraverseSum @Get @'SumOnly + +instance TypeError ENoEmpty => Get Void where get = undefined +instance TypeError ENoSum => Get (Either a b) where get = undefined + +{- + +-- | Parse a bytestring and... immediate reserialize it. +-- +-- Note that this _does_ perform work: we make a new bytestring so we don't rely +-- on the input bytestring. To use the input bytestring directly, see +-- "Binrep.Type.Thin". +instance Get Write where + {-# INLINE get #-} + get = fmap BZ.byteString $ fmap B.copy $ FP.takeRest + +-} + +instance Get a => Get (Identity a) where get = Identity <$> get + +-- | Unit type parses nothing. +instance Get () where + {-# INLINE get #-} + get = pure () + +-- | Parse tuples left-to-right. +instance (Get l, Get r) => Get (l, r) where + {-# INLINE get #-} + get = do + l <- get + r <- get + pure (l, r) + +-- | Parse elements until EOF. Sometimes used at the "top" of binary formats. +instance Get a => Get [a] where + get = go + where + go = do + FP.withOption FP.eof (\() -> pure []) $ do + a <- get + as <- go + pure $ a : as + +-- | Return the rest of the input. +-- +-- A plain unannotated bytestring isn't very useful -- you'll usually want to +-- null-terminate or length-prefix it. +-- +-- Note that this _does_ perform work: we make a new bytestring so we don't rely +-- on the input bytestring. To use the input bytestring directly, see +-- "Binrep.Type.Thin". +instance Get B.ByteString where + {-# INLINE get #-} + get = B.copy <$> FP.takeRest + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPrim Word8 instance Get Word8 + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPrim Int8 instance Get Int8 + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Identity Word8 instance Get (ByteOrdered end Word8) + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Identity Int8 instance Get (ByteOrdered end Int8) + +-- | Parse any 'Prim''. +getPrim :: forall a. Prim' a => Getter a +getPrim = getEBase FP.anyPrim (ERanOut (sizeOf (undefined :: a))) + +instance Prim' a => Get (ViaPrim a) where get = ViaPrim <$> getPrim + +-- ByteSwap is required on opposite endian platforms, but we're not checking +-- here, so make sure to keep it on both. +deriving via ViaPrim (ByteOrdered 'LittleEndian a) + instance (Prim' a, ByteSwap a) => Get (ByteOrdered 'LittleEndian a) +deriving via ViaPrim (ByteOrdered 'BigEndian a) + instance (Prim' a, ByteSwap a) => Get (ByteOrdered 'BigEndian a) + +{- + +-- | A type that can be parsed from binary given some environment. +-- +-- Making this levity polymorphic makes things pretty strange, but is useful. +-- See @Binrep.Example.FileTable@. +class GetWith (r :: TYPE rep) a | a -> r where + -- | Parse from binary with the given environment. + getWith :: r -> Getter a + -- can no longer provide default implementation due to levity polymorphism + --default getWith :: Get a => r -> Getter a + --getWith _ = get + +--deriving anyclass instance Get a => GetWith r [a] + +-- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You +-- can't bind (LHS) a levity polymorphic value. +runGetWith + :: GetWith (r :: TYPE LiftedRep) a + => r -> B.ByteString -> Either E (a, B.ByteString) +runGetWith r bs = runGetter (getWith r) bs + +-} diff --git a/src/Binrep/Get/Flatparse.hs b/src/Binrep/Get/Flatparse.hs deleted file mode 100644 --- a/src/Binrep/Get/Flatparse.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 -{-# LANGUAGE BlockArguments #-} - -module Binrep.Get.Flatparse - ( Getter, Get(..), runGet, runGetter - , E(..), EBase(..), EGeneric(..), EGenericSum(..) - , eBase - , getEBase - -- , GetWith(..), runGetWith - , getGenericNonSum, getGenericSum - ) where - -import FlatParse.Basic qualified as FP -import Data.ByteString qualified as B - -import Binrep.Util.Class -import GHC.TypeLits ( TypeError ) - -import Data.Void -import Data.Word -import Data.Int -import Bytezap -import Bytezap.Bytes qualified as BZ - -import Data.Text ( Text ) - -import Numeric.Natural - -import GHC.Generics -import Generic.Data.Function.Traverse -import Generic.Data.Function.Common -import Generic.Data.Rep.Assert - -import GHC.Exts ( minusAddr#, Int(I#) ) - -type Getter a = FP.Parser E a - --- | Structured parse error. -data E - = E Int EMiddle - - -- | Unhandled parse error. - -- - -- You get this if you don't change a flatparse fail to an error. - -- - -- Should not be set except by library code. - | EFail - - deriving stock (Eq, Show, Generic) - -data EMiddle - - -- | Parse error with no further context. - = EBase EBase - - -- | Somehow, we got two parse errors. - -- - -- I have a feeling that seeing this indicates a problem in your code. - | EAnd E EBase - - -- | Parse error decorated with generic info. - -- - -- Should not be set except by library code. - | EGeneric String {- ^ data type name -} (EGeneric E) - - deriving stock (Eq, Show, Generic) - -data EBase - = EExpectedByte Word8 Word8 - -- ^ expected first, got second - - | EOverlong Int Int - -- ^ expected first, got second - - | EExpected B.ByteString B.ByteString - -- ^ expected first, got second - - | EFailNamed String - -- ^ known fail - - | EFailParse String B.ByteString Word8 - -- ^ parse fail (where you parse a larger object, then a smaller one in it) - - | ERanOut Int - -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0) - -- - -- Actually a 'Natural', but we use 'Int' because that's what flatparse uses - -- internally. - - deriving stock (Eq, Show, Generic) - --- | A generic context layer for a parse error of type @e@. --- --- Recursive: parse errors occurring in fields are wrapped up here. (Those --- errors may also have a generic context layer.) --- --- Making this explicitly recursive may seem strange, but it clarifies that this --- data type is to be seen as a layer over a top-level type. -data EGeneric e - -- | Parse error relating to sum types (constructors). - = EGenericSum (EGenericSum e) - - -- | Parse error in a constructor field. - | EGenericField - String -- ^ constructor name - (Maybe String) -- ^ field record name (if present) - Natural -- ^ field index in constructor - e -- ^ field parse error - deriving stock (Eq, Show, Generic) - -data EGenericSum e - -- | Parse error parsing prefix tag. - = EGenericSumTag e - - -- | Unable to match a constructor to the parsed prefix tag. - | EGenericSumTagNoMatch - [String] -- ^ constructors tested - Text -- ^ prettified prefix tag - deriving stock (Eq, Show, Generic) - -eBase :: EBase -> Getter a -eBase eb = FP.ParserT \_fp eob s st -> - let os = I# (minusAddr# eob s) - in FP.Err# st (E os $ EBase eb) - -getEBase :: Getter a -> EBase -> Getter a -getEBase (FP.ParserT f) eb = - FP.ParserT \fp eob s st -> - let os = I# (minusAddr# eob s) - in case f fp eob s st of - FP.Fail# st' -> FP.Err# st' (E os $ EBase eb) - FP.Err# st' e -> FP.Err# st' (E os $ EAnd e eb) - x -> x - --- | Parse. On parse error, coat it in a generic context layer. -getWrapGeneric :: Get a => String -> (E -> EGeneric E) -> Getter a -getWrapGeneric = getWrapGeneric' get - -getWrapGeneric' :: Getter a -> String -> (E -> EGeneric E) -> Getter a -getWrapGeneric' (FP.ParserT f) cd fe = - FP.ParserT \fp eob s st -> - let os = I# (minusAddr# eob s) - in case f fp eob s st of - FP.Fail# st' -> FP.Err# st' (E os $ EGeneric cd $ fe EFail) - FP.Err# st' e -> FP.Err# st' (E os $ EGeneric cd $ fe e) - x -> x - -class Get a where - -- | Parse from binary. - get :: Getter a - -runGet :: Get a => B.ByteString -> Either E (a, B.ByteString) -runGet = runGetter get - -runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString) -runGetter g bs = case FP.runParser g bs of - FP.OK a bs' -> Right (a, bs') - FP.Fail -> Left EFail - FP.Err e -> Left e - -instance GenericTraverse (FP.Parser E) where - type GenericTraverseC (FP.Parser E) a = Get a - genericTraverseAction cd cc mcs si = - getWrapGeneric cd $ EGenericField cc mcs si - -instance GenericTraverseSum (FP.Parser E) where - genericTraverseSumPfxTagAction cd = - getWrapGeneric cd $ EGenericSum . EGenericSumTag - -- TODO proper offset info - genericTraverseSumNoMatchingCstrAction cd cstrs ptText = - FP.err $ E 0 $ EGeneric cd $ EGenericSum $ EGenericSumTagNoMatch cstrs ptText - -getGenericNonSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GTraverseNonSum cd (FP.Parser E) f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) - => Getter a -getGenericNonSum = genericTraverseNonSum @asserts - -getGenericSum - :: forall {cd} {f} {asserts} pt a - . ( Generic a, Rep a ~ D1 cd f, GTraverseSum 'SumOnly cd (FP.Parser E) f - , Get pt - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) - => PfxTagCfg pt -> Getter a -getGenericSum = genericTraverseSum @'SumOnly @asserts - -instance TypeError ENoEmpty => Get Void where get = undefined -instance TypeError ENoSum => Get (Either a b) where get = undefined - --- | Parse a bytestring and... immediate reserialize it. --- --- Note that this _does_ perform work: we make a new bytestring so we don't rely --- on the input bytestring. To use the input bytestring directly, see --- "Binrep.Type.Thin". -instance Get Write where - {-# INLINE get #-} - get = fmap BZ.byteString $ fmap B.copy $ FP.takeRest - --- | Unit type parses nothing. -instance Get () where - {-# INLINE get #-} - get = pure () - --- | Parse tuples left-to-right. -instance (Get l, Get r) => Get (l, r) where - {-# INLINE get #-} - get = do - l <- get - r <- get - pure (l, r) - --- | Parse elements until EOF. Sometimes used at the "top" of binary formats. -instance Get a => Get [a] where - get = go - where - go = do - FP.withOption FP.eof (\() -> pure []) $ do - a <- get - as <- go - pure $ a : as - --- | Return the rest of the input. --- --- A plain unannotated bytestring isn't very useful -- you'll usually want to --- null-terminate or length-prefix it. --- --- Note that this _does_ perform work: we make a new bytestring so we don't rely --- on the input bytestring. To use the input bytestring directly, see --- "Binrep.Type.Thin". -instance Get B.ByteString where - {-# INLINE get #-} - get = B.copy <$> FP.takeRest - --- | Unsigned byte. -instance Get Word8 where get = getEBase FP.anyWord8 (ERanOut 1) - --- | Signed byte. -instance Get Int8 where get = getEBase FP.anyInt8 (ERanOut 1) - -{- -Multi-byte machine integers require an endianness to use. A common wrapper is -defined in "Binrep.Type.Int". --} - -{- - --- | A type that can be parsed from binary given some environment. --- --- Making this levity polymorphic makes things pretty strange, but is useful. --- See @Binrep.Example.FileTable@. -class GetWith (r :: TYPE rep) a | a -> r where - -- | Parse from binary with the given environment. - getWith :: r -> Getter a - -- can no longer provide default implementation due to levity polymorphism - --default getWith :: Get a => r -> Getter a - --getWith _ = get - ---deriving anyclass instance Get a => GetWith r [a] - --- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You --- can't bind (LHS) a levity polymorphic value. -runGetWith - :: GetWith (r :: TYPE LiftedRep) a - => r -> B.ByteString -> Either E (a, B.ByteString) -runGetWith r bs = runGetter (getWith r) bs - --} diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 + +module Binrep.Put where + +import Binrep.BLen ( BLen(blen) ) +import Binrep.CBLen ( IsCBLen(CBLen), cblen ) +import Data.Functor.Identity +import Bytezap.Poke +import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf ) +import Binrep.Util.ByteOrder +import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap ) +import Binrep.Common.Via.Prim ( ViaPrim(..) ) + +import Data.ByteString qualified as B + +import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty ) +import GHC.TypeLits ( TypeError, KnownNat ) + +import Data.Void +import Data.Word +import Data.Int + +import GHC.Generics +import Generic.Data.Function.FoldMap +import Generic.Data.Function.Common +import Generic.Data.Rep.Assert + +import Control.Monad.ST ( RealWorld ) + +import Binrep.Put.Struct ( PutC(putC) ) + +type Putter = Poke RealWorld +class Put a where put :: a -> Putter + +runPut :: (BLen a, Put a) => a -> B.ByteString +runPut a = unsafeRunPokeBS (blen a) (put a) + +instance GenericFoldMap Put where + type GenericFoldMapM Put = Putter + type GenericFoldMapC Put a = Put a + genericFoldMapF = put + +-- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. +putGenericNonSum + :: forall a + . ( Generic a, GFoldMapNonSum Put (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => a -> Putter +putGenericNonSum = genericFoldMapNonSum @Put + +-- | Serialize a term of the sum type @a@ via its 'Generic' instance. +-- +-- You must provide a serializer for @a@'s constructors. This is regrettably +-- inefficient due to having to use 'String's. Alas. Do write your own instance +-- if you want better performance! +putGenericSum + :: forall a + . ( Generic a, GFoldMapSum Put 'SumOnly (Rep a) + , GAssertNotVoid a, GAssertSum a + ) => (String -> Putter) -> a -> Putter +putGenericSum = genericFoldMapSum @Put @'SumOnly + +newtype ViaPutC a = ViaPutC { unViaPutC :: a } +instance (PutC a, KnownNat (CBLen a)) => Put (ViaPutC a) where + {-# INLINE put #-} + put = fromStructPoke (cblen @a) . putC . unViaPutC + +-- use ViaPutC over this, but should be semantically identical +instance Prim' a => Put (ViaPrim a) where + put = fromStructPoke (sizeOf (undefined :: a)) . putC + {-# INLINE put #-} + +instance TypeError ENoEmpty => Put Void where put = undefined +instance TypeError ENoSum => Put (Either a b) where put = undefined + +instance Put a => Put (Identity a) where put = put . runIdentity + +instance Put Putter where put = id + +-- | Unit type serializes to nothing. How zen. +instance Put () where + {-# INLINE put #-} + put = mempty + +instance (Put l, Put r) => Put (l, r) where + {-# INLINE put #-} + put (l, r) = put l <> put r + +instance Put a => Put [a] where + {-# INLINE put #-} + put = mconcat . map put + +instance Put B.ByteString where + {-# INLINE put #-} + put = byteString + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPutC Word8 instance Put Word8 + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPutC Int8 instance Put Int8 + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Word8 instance Put (ByteOrdered end Word8) + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Int8 instance Put (ByteOrdered end Int8) + +-- ByteSwap is required on opposite endian platforms, but we're not checking +-- here, so make sure to keep it on both. +-- Stick with ViaPrim here because ByteOrdered is connected to it. +deriving via ViaPrim (ByteOrdered 'LittleEndian a) + instance (Prim' a, ByteSwap a) => Put (ByteOrdered 'LittleEndian a) +deriving via ViaPrim (ByteOrdered 'BigEndian a) + instance (Prim' a, ByteSwap a) => Put (ByteOrdered 'BigEndian a) diff --git a/src/Binrep/Put/Bytezap.hs b/src/Binrep/Put/Bytezap.hs deleted file mode 100644 --- a/src/Binrep/Put/Bytezap.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance - -{- | Serialization using the bytezap library. - -bytezap serializers ("pokes") work by writing bytes into a pointer, which is -assumed to have _precisely_ the space required. The user must determine the -post-serialize length before the fact. For that reason, this module requires -that types to be serialized have a 'BLen' instance. In general, we are happy -about this, because a binrep type should always have an efficient and preferably -simple 'BLen' instance (and if not, it shouldn't be a binrep type). --} - -module Binrep.Put.Bytezap where - -import Bytezap -import Bytezap.Poke.Bytes -import Bytezap.Poke.Int -import Data.ByteString qualified as B -import Binrep.BLen.Simple - -import Binrep.Util.Class -import GHC.TypeLits ( TypeError ) - -import Data.Void -import Data.Word -import Data.Int - -import GHC.Generics -import Generic.Data.Function.FoldMap -import Generic.Data.Function.Common -import Generic.Data.Rep.Assert - -class Put a where put :: a -> Poke - -runPut :: (BLen a, Put a) => a -> B.ByteString -runPut a = runPoke (blen a) (put a) -{-# INLINE runPut #-} - -instance GenericFoldMap Poke where - type GenericFoldMapC Poke a = Put a - genericFoldMapF = put - --- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. -putGenericNonSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Poke f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) - => a -> Poke -putGenericNonSum = genericFoldMapNonSum @asserts - --- | Serialize a term of the sum type @a@ via its 'Generic' instance. --- --- You must provide a serializer for @a@'s constructors. This is regrettably --- inefficient due to having to use 'String's. Alas. Do write your own instance --- if you want better performance! -putGenericSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Poke f - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) - => (String -> Poke) -> a -> Poke -putGenericSum = genericFoldMapSum @'SumOnly @asserts - -instance TypeError ENoEmpty => Put Void where put = undefined -instance TypeError ENoSum => Put (Either a b) where put = undefined - -instance Put Write where - {-# INLINE put #-} - put = writePoke - --- | Fairly useless because 'Poke' doesn't have a 'BLen' instance. -instance Put Poke where - {-# INLINE put #-} - put = id - --- | Unit type serializes to nothing. How zen. -instance Put () where - {-# INLINE put #-} - put = mempty - -instance (Put l, Put r) => Put (l, r) where - {-# INLINE put #-} - put (l, r) = put l <> put r - -instance Put a => Put [a] where - {-# INLINE put #-} - put = mconcat . map put - -instance Put B.ByteString where - {-# INLINE put #-} - put = byteString - -instance Put Word8 where - {-# INLINE put #-} - put = w8 - -instance Put Int8 where - {-# INLINE put #-} - put = i8 diff --git a/src/Binrep/Put/Mason.hs b/src/Binrep/Put/Mason.hs deleted file mode 100644 --- a/src/Binrep/Put/Mason.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance - --- TODO some instances are wrong, Void should be typeerror - -module Binrep.Put.Mason where - -import Mason.Builder qualified as Mason - -import Data.ByteString qualified as B - -import Data.Word -import Data.Int -import Data.Void ( Void, absurd ) - -import GHC.Generics -import Generic.Data.Function.FoldMap -import Generic.Data.Function.Common -import Generic.Data.Rep.Assert - -type Builder = Mason.BuilderFor Mason.StrictByteStringBackend - -class Put a where - -- | Serialize to binary. - put :: a -> Builder - --- | Run the serializer. -runPut :: Put a => a -> B.ByteString -runPut = runBuilder . put - -runBuilder :: Builder -> B.ByteString -runBuilder = Mason.toStrictByteString - -instance GenericFoldMap Builder where - type GenericFoldMapC Builder a = Put a - genericFoldMapF = put - --- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. -putGenericNonSum - :: forall {cd} {f} {asserts} a - . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Builder f - , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) - => a -> Builder -putGenericNonSum = genericFoldMapNonSum @asserts - --- | Serialize a term of the sum type @a@ via its 'Generic' instance. --- --- You must provide a serializer for @a@'s constructors. This is regrettably --- inefficient due to having to use 'String's. Alas. Do write your own instance --- if you want better performance! -putGenericSum - :: forall {cd} {f} {asserts} a - . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Builder f - , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) - => (String -> Builder) -> a -> Builder -putGenericSum = genericFoldMapSum @'SumOnly @asserts - --- | Impossible to serialize 'Void'. -instance Put Void where - put = absurd - --- | Serialize each element in order. No length indicator, so parse until either --- error or EOF. Usually not what you want, but sometimes used at the "top" of --- binary formats. -instance Put a => Put [a] where - put = mconcat . map put - -instance (Put a, Put b) => Put (a, b) where - put (a, b) = put a <> put b - --- | Serialize the bytestring as-is. --- --- Careful -- the only way you're going to be able to parse this is to read --- until EOF. -instance Put B.ByteString where - put = Mason.byteString - {-# INLINE put #-} - --- need to give args for RankNTypes reasons I don't understand -instance Put Word8 where - put w = Mason.word8 w - {-# INLINE put #-} -instance Put Int8 where - put w = Mason.int8 w - {-# INLINE put #-} - --- | Put with inlined checks via an environment. -class PutWith r a where - -- | Attempt to serialize to binary with the given environment. - putWith :: r -> a -> Either String Builder - default putWith :: Put a => r -> a -> Either String Builder - putWith _ = putWithout - --- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding). -putWithout :: Put a => a -> Either String Builder -putWithout = Right . put - -instance Put a => PutWith r [a] - --- | Run the serializer with the given environment. -runPutWith :: PutWith r a => r -> a -> Either String B.ByteString -runPutWith r a = case putWith r a of Left e -> Left e - Right x -> Right $ runBuilder x diff --git a/src/Binrep/Put/Struct.hs b/src/Binrep/Put/Struct.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put/Struct.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE UndecidableInstances #-} -- for @KnownNat (CBLen a)@ in head + +module Binrep.Put.Struct where + +import Bytezap.Struct qualified as Struct +import Bytezap.Struct.Generic qualified as Struct +import Control.Monad.ST ( RealWorld ) +import Binrep.CBLen +import GHC.TypeLits ( KnownNat ) +import GHC.Generics +import Data.ByteString qualified as B + +import Binrep.Common.Via.Prim ( ViaPrim(..) ) +import Raehik.Compat.Data.Primitive.Types ( Prim' ) +import Data.Word +import Data.Int +import Binrep.Util.ByteOrder +import Data.Functor.Identity +import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap ) + +import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty ) +import GHC.TypeLits ( TypeError ) +import Data.Void + +type PutterC = Struct.Poke RealWorld + +-- | constant size putter +class PutC a where putC :: a -> PutterC + +runPutC :: forall a. (PutC a, KnownNat (CBLen a)) => a -> B.ByteString +runPutC = Struct.unsafeRunPokeBS (cblen @a) . putC + +instance Struct.GPokeBase PutC where + type GPokeBaseSt PutC = RealWorld + type GPokeBaseC PutC a = PutC a + gPokeBase = Struct.unPoke . putC + type KnownSizeOf' PutC a = KnownNat (CBLen a) + sizeOf' = cblenProxy# + +-- | Serialize a term of the struct-like type @a@ via its 'Generic' instance. +putGenericStruct + :: forall a + . ( Generic a, Struct.GPoke PutC (Rep a) ) + => a -> PutterC +putGenericStruct = Struct.Poke . Struct.gPoke @PutC . from + +instance Prim' a => PutC (ViaPrim a) where + putC = Struct.prim . unViaPrim + {-# INLINE putC #-} + +instance TypeError ENoEmpty => PutC Void where putC = undefined +instance TypeError ENoSum => PutC (Either a b) where putC = undefined + +instance PutC a => PutC (Identity a) where putC = putC . runIdentity + +instance PutC PutterC where putC = id + +-- | Unit type serializes to nothing. How zen. +instance PutC () where + {-# INLINE putC #-} + putC () = Struct.emptyPoke + +-- | Look weird? Yeah. But it's correct :) +instance (PutC l, KnownNat (CBLen l), PutC r) => PutC (l, r) where + {-# INLINE putC #-} + putC (l, r) = Struct.sequencePokes (putC l) (cblen @l) (putC r) + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPrim Word8 instance PutC Word8 + +-- | 8-bit (1-byte) words do not require byte order in order to precisely +-- define their representation. +deriving via ViaPrim Int8 instance PutC Int8 + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Word8 instance PutC (ByteOrdered end Word8) + +-- | Byte order is irrelevant for 8-bit (1-byte) words. +deriving via Int8 instance PutC (ByteOrdered end Int8) + +-- ByteSwap is required on opposite endian platforms, but we're not checking +-- here, so make sure to keep it on both. +deriving via ViaPrim (ByteOrdered 'LittleEndian a) + instance (Prim' a, ByteSwap a) => PutC (ByteOrdered 'LittleEndian a) +deriving via ViaPrim (ByteOrdered 'BigEndian a) + instance (Prim' a, ByteSwap a) => PutC (ByteOrdered 'BigEndian a) diff --git a/src/Binrep/Test.hs b/src/Binrep/Test.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Test.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Binrep.Test where + +import Binrep +import Binrep.Type.Magic +import Binrep.CBLen.Generic +import GHC.Generics ( Generic ) + +data DMagic = DMagic + { dMagic1_8b :: Magic '[0xFF, 0, 1, 0, 1, 0, 1, 0xFF] + } deriving stock Generic + +instance IsCBLen DMagic where type CBLen DMagic = CBLenGeneric () DMagic +instance PutC DMagic where putC = putGenericStruct diff --git a/src/Binrep/Type/Byte.hs b/src/Binrep/Type/Byte.hs deleted file mode 100644 --- a/src/Binrep/Type/Byte.hs +++ /dev/null @@ -1,809 +0,0 @@ -{- | Safe, if silly, byte representation for use at the type level. - -'Word8' is a special type that GHC doesn't (and I think can't) promote to the -type level. We only have 'Natural's, which are unbounded. So we define a safe, -promotable representation, to allow us to prove well-sizedness at compile time. -Then we provide a bunch of type families and reifying typeclasses to enable -going between "similar" kinds ('Natural') and types ('Word8', 'B.ByteString') -respectively. - -Type-level functionality is stored in 'Binrep.Type.Byte.TypeLevel' because the -definitions are even sillier than the ones here. - -Do not use this on the term level. That would be _extremely_ silly. --} - -{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-} - -module Binrep.Type.Byte where - -import Bytezap qualified as BZ -import Bytezap.Poke.Int qualified as BZ -import GHC.TypeNats -import GHC.Word - --- | Efficiently reify a list of type-level 'Natural' bytes to to a bytestring --- builder. --- --- Attempting to reify a 'Natural' larger than 255 results in a type error. --- --- This is about as far as one should go for pointless performance here, I --- should think. -class ReifyBytes (ns :: [Natural]) where reifyBytes :: BZ.Poke -instance ReifyBytes '[] where - {-# INLINE reifyBytes #-} - reifyBytes = mempty -instance (ByteVal n, ReifyBytes ns) => ReifyBytes (n ': ns) where - {-# INLINE reifyBytes #-} - reifyBytes = BZ.w8 (byteVal @n) <> reifyBytes @ns - -class ByteVal (n :: Natural) where byteVal :: Word8 - -instance ByteVal 0x00 where - {-# INLINE byteVal #-} - byteVal = 0x00 -instance ByteVal 0x01 where - {-# INLINE byteVal #-} - byteVal = 0x01 -instance ByteVal 0x02 where - {-# INLINE byteVal #-} - byteVal = 0x02 -instance ByteVal 0x03 where - {-# INLINE byteVal #-} - byteVal = 0x03 -instance ByteVal 0x04 where - {-# INLINE byteVal #-} - byteVal = 0x04 -instance ByteVal 0x05 where - {-# INLINE byteVal #-} - byteVal = 0x05 -instance ByteVal 0x06 where - {-# INLINE byteVal #-} - byteVal = 0x06 -instance ByteVal 0x07 where - {-# INLINE byteVal #-} - byteVal = 0x07 -instance ByteVal 0x08 where - {-# INLINE byteVal #-} - byteVal = 0x08 -instance ByteVal 0x09 where - {-# INLINE byteVal #-} - byteVal = 0x09 -instance ByteVal 0x0a where - {-# INLINE byteVal #-} - byteVal = 0x0a -instance ByteVal 0x0b where - {-# INLINE byteVal #-} - byteVal = 0x0b -instance ByteVal 0x0c where - {-# INLINE byteVal #-} - byteVal = 0x0c -instance ByteVal 0x0d where - {-# INLINE byteVal #-} - byteVal = 0x0d -instance ByteVal 0x0e where - {-# INLINE byteVal #-} - byteVal = 0x0e -instance ByteVal 0x0f where - {-# INLINE byteVal #-} - byteVal = 0x0f -instance ByteVal 0x10 where - {-# INLINE byteVal #-} - byteVal = 0x10 -instance ByteVal 0x11 where - {-# INLINE byteVal #-} - byteVal = 0x11 -instance ByteVal 0x12 where - {-# INLINE byteVal #-} - byteVal = 0x12 -instance ByteVal 0x13 where - {-# INLINE byteVal #-} - byteVal = 0x13 -instance ByteVal 0x14 where - {-# INLINE byteVal #-} - byteVal = 0x14 -instance ByteVal 0x15 where - {-# INLINE byteVal #-} - byteVal = 0x15 -instance ByteVal 0x16 where - {-# INLINE byteVal #-} - byteVal = 0x16 -instance ByteVal 0x17 where - {-# INLINE byteVal #-} - byteVal = 0x17 -instance ByteVal 0x18 where - {-# INLINE byteVal #-} - byteVal = 0x18 -instance ByteVal 0x19 where - {-# INLINE byteVal #-} - byteVal = 0x19 -instance ByteVal 0x1a where - {-# INLINE byteVal #-} - byteVal = 0x1a -instance ByteVal 0x1b where - {-# INLINE byteVal #-} - byteVal = 0x1b -instance ByteVal 0x1c where - {-# INLINE byteVal #-} - byteVal = 0x1c -instance ByteVal 0x1d where - {-# INLINE byteVal #-} - byteVal = 0x1d -instance ByteVal 0x1e where - {-# INLINE byteVal #-} - byteVal = 0x1e -instance ByteVal 0x1f where - {-# INLINE byteVal #-} - byteVal = 0x1f -instance ByteVal 0x20 where - {-# INLINE byteVal #-} - byteVal = 0x20 -instance ByteVal 0x21 where - {-# INLINE byteVal #-} - byteVal = 0x21 -instance ByteVal 0x22 where - {-# INLINE byteVal #-} - byteVal = 0x22 -instance ByteVal 0x23 where - {-# INLINE byteVal #-} - byteVal = 0x23 -instance ByteVal 0x24 where - {-# INLINE byteVal #-} - byteVal = 0x24 -instance ByteVal 0x25 where - {-# INLINE byteVal #-} - byteVal = 0x25 -instance ByteVal 0x26 where - {-# INLINE byteVal #-} - byteVal = 0x26 -instance ByteVal 0x27 where - {-# INLINE byteVal #-} - byteVal = 0x27 -instance ByteVal 0x28 where - {-# INLINE byteVal #-} - byteVal = 0x28 -instance ByteVal 0x29 where - {-# INLINE byteVal #-} - byteVal = 0x29 -instance ByteVal 0x2a where - {-# INLINE byteVal #-} - byteVal = 0x2a -instance ByteVal 0x2b where - {-# INLINE byteVal #-} - byteVal = 0x2b -instance ByteVal 0x2c where - {-# INLINE byteVal #-} - byteVal = 0x2c -instance ByteVal 0x2d where - {-# INLINE byteVal #-} - byteVal = 0x2d -instance ByteVal 0x2e where - {-# INLINE byteVal #-} - byteVal = 0x2e -instance ByteVal 0x2f where - {-# INLINE byteVal #-} - byteVal = 0x2f -instance ByteVal 0x30 where - {-# INLINE byteVal #-} - byteVal = 0x30 -instance ByteVal 0x31 where - {-# INLINE byteVal #-} - byteVal = 0x31 -instance ByteVal 0x32 where - {-# INLINE byteVal #-} - byteVal = 0x32 -instance ByteVal 0x33 where - {-# INLINE byteVal #-} - byteVal = 0x33 -instance ByteVal 0x34 where - {-# INLINE byteVal #-} - byteVal = 0x34 -instance ByteVal 0x35 where - {-# INLINE byteVal #-} - byteVal = 0x35 -instance ByteVal 0x36 where - {-# INLINE byteVal #-} - byteVal = 0x36 -instance ByteVal 0x37 where - {-# INLINE byteVal #-} - byteVal = 0x37 -instance ByteVal 0x38 where - {-# INLINE byteVal #-} - byteVal = 0x38 -instance ByteVal 0x39 where - {-# INLINE byteVal #-} - byteVal = 0x39 -instance ByteVal 0x3a where - {-# INLINE byteVal #-} - byteVal = 0x3a -instance ByteVal 0x3b where - {-# INLINE byteVal #-} - byteVal = 0x3b -instance ByteVal 0x3c where - {-# INLINE byteVal #-} - byteVal = 0x3c -instance ByteVal 0x3d where - {-# INLINE byteVal #-} - byteVal = 0x3d -instance ByteVal 0x3e where - {-# INLINE byteVal #-} - byteVal = 0x3e -instance ByteVal 0x3f where - {-# INLINE byteVal #-} - byteVal = 0x3f -instance ByteVal 0x40 where - {-# INLINE byteVal #-} - byteVal = 0x40 -instance ByteVal 0x41 where - {-# INLINE byteVal #-} - byteVal = 0x41 -instance ByteVal 0x42 where - {-# INLINE byteVal #-} - byteVal = 0x42 -instance ByteVal 0x43 where - {-# INLINE byteVal #-} - byteVal = 0x43 -instance ByteVal 0x44 where - {-# INLINE byteVal #-} - byteVal = 0x44 -instance ByteVal 0x45 where - {-# INLINE byteVal #-} - byteVal = 0x45 -instance ByteVal 0x46 where - {-# INLINE byteVal #-} - byteVal = 0x46 -instance ByteVal 0x47 where - {-# INLINE byteVal #-} - byteVal = 0x47 -instance ByteVal 0x48 where - {-# INLINE byteVal #-} - byteVal = 0x48 -instance ByteVal 0x49 where - {-# INLINE byteVal #-} - byteVal = 0x49 -instance ByteVal 0x4a where - {-# INLINE byteVal #-} - byteVal = 0x4a -instance ByteVal 0x4b where - {-# INLINE byteVal #-} - byteVal = 0x4b -instance ByteVal 0x4c where - {-# INLINE byteVal #-} - byteVal = 0x4c -instance ByteVal 0x4d where - {-# INLINE byteVal #-} - byteVal = 0x4d -instance ByteVal 0x4e where - {-# INLINE byteVal #-} - byteVal = 0x4e -instance ByteVal 0x4f where - {-# INLINE byteVal #-} - byteVal = 0x4f -instance ByteVal 0x50 where - {-# INLINE byteVal #-} - byteVal = 0x50 -instance ByteVal 0x51 where - {-# INLINE byteVal #-} - byteVal = 0x51 -instance ByteVal 0x52 where - {-# INLINE byteVal #-} - byteVal = 0x52 -instance ByteVal 0x53 where - {-# INLINE byteVal #-} - byteVal = 0x53 -instance ByteVal 0x54 where - {-# INLINE byteVal #-} - byteVal = 0x54 -instance ByteVal 0x55 where - {-# INLINE byteVal #-} - byteVal = 0x55 -instance ByteVal 0x56 where - {-# INLINE byteVal #-} - byteVal = 0x56 -instance ByteVal 0x57 where - {-# INLINE byteVal #-} - byteVal = 0x57 -instance ByteVal 0x58 where - {-# INLINE byteVal #-} - byteVal = 0x58 -instance ByteVal 0x59 where - {-# INLINE byteVal #-} - byteVal = 0x59 -instance ByteVal 0x5a where - {-# INLINE byteVal #-} - byteVal = 0x5a -instance ByteVal 0x5b where - {-# INLINE byteVal #-} - byteVal = 0x5b -instance ByteVal 0x5c where - {-# INLINE byteVal #-} - byteVal = 0x5c -instance ByteVal 0x5d where - {-# INLINE byteVal #-} - byteVal = 0x5d -instance ByteVal 0x5e where - {-# INLINE byteVal #-} - byteVal = 0x5e -instance ByteVal 0x5f where - {-# INLINE byteVal #-} - byteVal = 0x5f -instance ByteVal 0x60 where - {-# INLINE byteVal #-} - byteVal = 0x60 -instance ByteVal 0x61 where - {-# INLINE byteVal #-} - byteVal = 0x61 -instance ByteVal 0x62 where - {-# INLINE byteVal #-} - byteVal = 0x62 -instance ByteVal 0x63 where - {-# INLINE byteVal #-} - byteVal = 0x63 -instance ByteVal 0x64 where - {-# INLINE byteVal #-} - byteVal = 0x64 -instance ByteVal 0x65 where - {-# INLINE byteVal #-} - byteVal = 0x65 -instance ByteVal 0x66 where - {-# INLINE byteVal #-} - byteVal = 0x66 -instance ByteVal 0x67 where - {-# INLINE byteVal #-} - byteVal = 0x67 -instance ByteVal 0x68 where - {-# INLINE byteVal #-} - byteVal = 0x68 -instance ByteVal 0x69 where - {-# INLINE byteVal #-} - byteVal = 0x69 -instance ByteVal 0x6a where - {-# INLINE byteVal #-} - byteVal = 0x6a -instance ByteVal 0x6b where - {-# INLINE byteVal #-} - byteVal = 0x6b -instance ByteVal 0x6c where - {-# INLINE byteVal #-} - byteVal = 0x6c -instance ByteVal 0x6d where - {-# INLINE byteVal #-} - byteVal = 0x6d -instance ByteVal 0x6e where - {-# INLINE byteVal #-} - byteVal = 0x6e -instance ByteVal 0x6f where - {-# INLINE byteVal #-} - byteVal = 0x6f -instance ByteVal 0x70 where - {-# INLINE byteVal #-} - byteVal = 0x70 -instance ByteVal 0x71 where - {-# INLINE byteVal #-} - byteVal = 0x71 -instance ByteVal 0x72 where - {-# INLINE byteVal #-} - byteVal = 0x72 -instance ByteVal 0x73 where - {-# INLINE byteVal #-} - byteVal = 0x73 -instance ByteVal 0x74 where - {-# INLINE byteVal #-} - byteVal = 0x74 -instance ByteVal 0x75 where - {-# INLINE byteVal #-} - byteVal = 0x75 -instance ByteVal 0x76 where - {-# INLINE byteVal #-} - byteVal = 0x76 -instance ByteVal 0x77 where - {-# INLINE byteVal #-} - byteVal = 0x77 -instance ByteVal 0x78 where - {-# INLINE byteVal #-} - byteVal = 0x78 -instance ByteVal 0x79 where - {-# INLINE byteVal #-} - byteVal = 0x79 -instance ByteVal 0x7a where - {-# INLINE byteVal #-} - byteVal = 0x7a -instance ByteVal 0x7b where - {-# INLINE byteVal #-} - byteVal = 0x7b -instance ByteVal 0x7c where - {-# INLINE byteVal #-} - byteVal = 0x7c -instance ByteVal 0x7d where - {-# INLINE byteVal #-} - byteVal = 0x7d -instance ByteVal 0x7e where - {-# INLINE byteVal #-} - byteVal = 0x7e -instance ByteVal 0x7f where - {-# INLINE byteVal #-} - byteVal = 0x7f -instance ByteVal 0x80 where - {-# INLINE byteVal #-} - byteVal = 0x80 -instance ByteVal 0x81 where - {-# INLINE byteVal #-} - byteVal = 0x81 -instance ByteVal 0x82 where - {-# INLINE byteVal #-} - byteVal = 0x82 -instance ByteVal 0x83 where - {-# INLINE byteVal #-} - byteVal = 0x83 -instance ByteVal 0x84 where - {-# INLINE byteVal #-} - byteVal = 0x84 -instance ByteVal 0x85 where - {-# INLINE byteVal #-} - byteVal = 0x85 -instance ByteVal 0x86 where - {-# INLINE byteVal #-} - byteVal = 0x86 -instance ByteVal 0x87 where - {-# INLINE byteVal #-} - byteVal = 0x87 -instance ByteVal 0x88 where - {-# INLINE byteVal #-} - byteVal = 0x88 -instance ByteVal 0x89 where - {-# INLINE byteVal #-} - byteVal = 0x89 -instance ByteVal 0x8a where - {-# INLINE byteVal #-} - byteVal = 0x8a -instance ByteVal 0x8b where - {-# INLINE byteVal #-} - byteVal = 0x8b -instance ByteVal 0x8c where - {-# INLINE byteVal #-} - byteVal = 0x8c -instance ByteVal 0x8d where - {-# INLINE byteVal #-} - byteVal = 0x8d -instance ByteVal 0x8e where - {-# INLINE byteVal #-} - byteVal = 0x8e -instance ByteVal 0x8f where - {-# INLINE byteVal #-} - byteVal = 0x8f -instance ByteVal 0x90 where - {-# INLINE byteVal #-} - byteVal = 0x90 -instance ByteVal 0x91 where - {-# INLINE byteVal #-} - byteVal = 0x91 -instance ByteVal 0x92 where - {-# INLINE byteVal #-} - byteVal = 0x92 -instance ByteVal 0x93 where - {-# INLINE byteVal #-} - byteVal = 0x93 -instance ByteVal 0x94 where - {-# INLINE byteVal #-} - byteVal = 0x94 -instance ByteVal 0x95 where - {-# INLINE byteVal #-} - byteVal = 0x95 -instance ByteVal 0x96 where - {-# INLINE byteVal #-} - byteVal = 0x96 -instance ByteVal 0x97 where - {-# INLINE byteVal #-} - byteVal = 0x97 -instance ByteVal 0x98 where - {-# INLINE byteVal #-} - byteVal = 0x98 -instance ByteVal 0x99 where - {-# INLINE byteVal #-} - byteVal = 0x99 -instance ByteVal 0x9a where - {-# INLINE byteVal #-} - byteVal = 0x9a -instance ByteVal 0x9b where - {-# INLINE byteVal #-} - byteVal = 0x9b -instance ByteVal 0x9c where - {-# INLINE byteVal #-} - byteVal = 0x9c -instance ByteVal 0x9d where - {-# INLINE byteVal #-} - byteVal = 0x9d -instance ByteVal 0x9e where - {-# INLINE byteVal #-} - byteVal = 0x9e -instance ByteVal 0x9f where - {-# INLINE byteVal #-} - byteVal = 0x9f -instance ByteVal 0xa0 where - {-# INLINE byteVal #-} - byteVal = 0xa0 -instance ByteVal 0xa1 where - {-# INLINE byteVal #-} - byteVal = 0xa1 -instance ByteVal 0xa2 where - {-# INLINE byteVal #-} - byteVal = 0xa2 -instance ByteVal 0xa3 where - {-# INLINE byteVal #-} - byteVal = 0xa3 -instance ByteVal 0xa4 where - {-# INLINE byteVal #-} - byteVal = 0xa4 -instance ByteVal 0xa5 where - {-# INLINE byteVal #-} - byteVal = 0xa5 -instance ByteVal 0xa6 where - {-# INLINE byteVal #-} - byteVal = 0xa6 -instance ByteVal 0xa7 where - {-# INLINE byteVal #-} - byteVal = 0xa7 -instance ByteVal 0xa8 where - {-# INLINE byteVal #-} - byteVal = 0xa8 -instance ByteVal 0xa9 where - {-# INLINE byteVal #-} - byteVal = 0xa9 -instance ByteVal 0xaa where - {-# INLINE byteVal #-} - byteVal = 0xaa -instance ByteVal 0xab where - {-# INLINE byteVal #-} - byteVal = 0xab -instance ByteVal 0xac where - {-# INLINE byteVal #-} - byteVal = 0xac -instance ByteVal 0xad where - {-# INLINE byteVal #-} - byteVal = 0xad -instance ByteVal 0xae where - {-# INLINE byteVal #-} - byteVal = 0xae -instance ByteVal 0xaf where - {-# INLINE byteVal #-} - byteVal = 0xaf -instance ByteVal 0xb0 where - {-# INLINE byteVal #-} - byteVal = 0xb0 -instance ByteVal 0xb1 where - {-# INLINE byteVal #-} - byteVal = 0xb1 -instance ByteVal 0xb2 where - {-# INLINE byteVal #-} - byteVal = 0xb2 -instance ByteVal 0xb3 where - {-# INLINE byteVal #-} - byteVal = 0xb3 -instance ByteVal 0xb4 where - {-# INLINE byteVal #-} - byteVal = 0xb4 -instance ByteVal 0xb5 where - {-# INLINE byteVal #-} - byteVal = 0xb5 -instance ByteVal 0xb6 where - {-# INLINE byteVal #-} - byteVal = 0xb6 -instance ByteVal 0xb7 where - {-# INLINE byteVal #-} - byteVal = 0xb7 -instance ByteVal 0xb8 where - {-# INLINE byteVal #-} - byteVal = 0xb8 -instance ByteVal 0xb9 where - {-# INLINE byteVal #-} - byteVal = 0xb9 -instance ByteVal 0xba where - {-# INLINE byteVal #-} - byteVal = 0xba -instance ByteVal 0xbb where - {-# INLINE byteVal #-} - byteVal = 0xbb -instance ByteVal 0xbc where - {-# INLINE byteVal #-} - byteVal = 0xbc -instance ByteVal 0xbd where - {-# INLINE byteVal #-} - byteVal = 0xbd -instance ByteVal 0xbe where - {-# INLINE byteVal #-} - byteVal = 0xbe -instance ByteVal 0xbf where - {-# INLINE byteVal #-} - byteVal = 0xbf -instance ByteVal 0xc0 where - {-# INLINE byteVal #-} - byteVal = 0xc0 -instance ByteVal 0xc1 where - {-# INLINE byteVal #-} - byteVal = 0xc1 -instance ByteVal 0xc2 where - {-# INLINE byteVal #-} - byteVal = 0xc2 -instance ByteVal 0xc3 where - {-# INLINE byteVal #-} - byteVal = 0xc3 -instance ByteVal 0xc4 where - {-# INLINE byteVal #-} - byteVal = 0xc4 -instance ByteVal 0xc5 where - {-# INLINE byteVal #-} - byteVal = 0xc5 -instance ByteVal 0xc6 where - {-# INLINE byteVal #-} - byteVal = 0xc6 -instance ByteVal 0xc7 where - {-# INLINE byteVal #-} - byteVal = 0xc7 -instance ByteVal 0xc8 where - {-# INLINE byteVal #-} - byteVal = 0xc8 -instance ByteVal 0xc9 where - {-# INLINE byteVal #-} - byteVal = 0xc9 -instance ByteVal 0xca where - {-# INLINE byteVal #-} - byteVal = 0xca -instance ByteVal 0xcb where - {-# INLINE byteVal #-} - byteVal = 0xcb -instance ByteVal 0xcc where - {-# INLINE byteVal #-} - byteVal = 0xcc -instance ByteVal 0xcd where - {-# INLINE byteVal #-} - byteVal = 0xcd -instance ByteVal 0xce where - {-# INLINE byteVal #-} - byteVal = 0xce -instance ByteVal 0xcf where - {-# INLINE byteVal #-} - byteVal = 0xcf -instance ByteVal 0xd0 where - {-# INLINE byteVal #-} - byteVal = 0xd0 -instance ByteVal 0xd1 where - {-# INLINE byteVal #-} - byteVal = 0xd1 -instance ByteVal 0xd2 where - {-# INLINE byteVal #-} - byteVal = 0xd2 -instance ByteVal 0xd3 where - {-# INLINE byteVal #-} - byteVal = 0xd3 -instance ByteVal 0xd4 where - {-# INLINE byteVal #-} - byteVal = 0xd4 -instance ByteVal 0xd5 where - {-# INLINE byteVal #-} - byteVal = 0xd5 -instance ByteVal 0xd6 where - {-# INLINE byteVal #-} - byteVal = 0xd6 -instance ByteVal 0xd7 where - {-# INLINE byteVal #-} - byteVal = 0xd7 -instance ByteVal 0xd8 where - {-# INLINE byteVal #-} - byteVal = 0xd8 -instance ByteVal 0xd9 where - {-# INLINE byteVal #-} - byteVal = 0xd9 -instance ByteVal 0xda where - {-# INLINE byteVal #-} - byteVal = 0xda -instance ByteVal 0xdb where - {-# INLINE byteVal #-} - byteVal = 0xdb -instance ByteVal 0xdc where - {-# INLINE byteVal #-} - byteVal = 0xdc -instance ByteVal 0xdd where - {-# INLINE byteVal #-} - byteVal = 0xdd -instance ByteVal 0xde where - {-# INLINE byteVal #-} - byteVal = 0xde -instance ByteVal 0xdf where - {-# INLINE byteVal #-} - byteVal = 0xdf -instance ByteVal 0xe0 where - {-# INLINE byteVal #-} - byteVal = 0xe0 -instance ByteVal 0xe1 where - {-# INLINE byteVal #-} - byteVal = 0xe1 -instance ByteVal 0xe2 where - {-# INLINE byteVal #-} - byteVal = 0xe2 -instance ByteVal 0xe3 where - {-# INLINE byteVal #-} - byteVal = 0xe3 -instance ByteVal 0xe4 where - {-# INLINE byteVal #-} - byteVal = 0xe4 -instance ByteVal 0xe5 where - {-# INLINE byteVal #-} - byteVal = 0xe5 -instance ByteVal 0xe6 where - {-# INLINE byteVal #-} - byteVal = 0xe6 -instance ByteVal 0xe7 where - {-# INLINE byteVal #-} - byteVal = 0xe7 -instance ByteVal 0xe8 where - {-# INLINE byteVal #-} - byteVal = 0xe8 -instance ByteVal 0xe9 where - {-# INLINE byteVal #-} - byteVal = 0xe9 -instance ByteVal 0xea where - {-# INLINE byteVal #-} - byteVal = 0xea -instance ByteVal 0xeb where - {-# INLINE byteVal #-} - byteVal = 0xeb -instance ByteVal 0xec where - {-# INLINE byteVal #-} - byteVal = 0xec -instance ByteVal 0xed where - {-# INLINE byteVal #-} - byteVal = 0xed -instance ByteVal 0xee where - {-# INLINE byteVal #-} - byteVal = 0xee -instance ByteVal 0xef where - {-# INLINE byteVal #-} - byteVal = 0xef -instance ByteVal 0xf0 where - {-# INLINE byteVal #-} - byteVal = 0xf0 -instance ByteVal 0xf1 where - {-# INLINE byteVal #-} - byteVal = 0xf1 -instance ByteVal 0xf2 where - {-# INLINE byteVal #-} - byteVal = 0xf2 -instance ByteVal 0xf3 where - {-# INLINE byteVal #-} - byteVal = 0xf3 -instance ByteVal 0xf4 where - {-# INLINE byteVal #-} - byteVal = 0xf4 -instance ByteVal 0xf5 where - {-# INLINE byteVal #-} - byteVal = 0xf5 -instance ByteVal 0xf6 where - {-# INLINE byteVal #-} - byteVal = 0xf6 -instance ByteVal 0xf7 where - {-# INLINE byteVal #-} - byteVal = 0xf7 -instance ByteVal 0xf8 where - {-# INLINE byteVal #-} - byteVal = 0xf8 -instance ByteVal 0xf9 where - {-# INLINE byteVal #-} - byteVal = 0xf9 -instance ByteVal 0xfa where - {-# INLINE byteVal #-} - byteVal = 0xfa -instance ByteVal 0xfb where - {-# INLINE byteVal #-} - byteVal = 0xfb -instance ByteVal 0xfc where - {-# INLINE byteVal #-} - byteVal = 0xfc -instance ByteVal 0xfd where - {-# INLINE byteVal #-} - byteVal = 0xfd -instance ByteVal 0xfe where - {-# INLINE byteVal #-} - byteVal = 0xfe -instance ByteVal 0xff where - {-# INLINE byteVal #-} - byteVal = 0xff diff --git a/src/Binrep/Type/Common.hs b/src/Binrep/Type/Common.hs deleted file mode 100644 --- a/src/Binrep/Type/Common.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Binrep.Type.Common where - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - --- | Byte order. -data Endianness - = LE -- ^ little endian, MSB last. e.g. most processor architectures - | BE -- ^ big endian, MSB first. e.g. most network protocols - deriving stock (Generic, Data, Show, Eq) diff --git a/src/Binrep/Type/Int.hs b/src/Binrep/Type/Int.hs deleted file mode 100644 --- a/src/Binrep/Type/Int.hs +++ /dev/null @@ -1,142 +0,0 @@ --- | "Machine" integers: sized integers & naturals with explicit endianness type --- tags for serialization. - -{-# LANGUAGE CPP #-} -- for host endianness checking -{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic - -module Binrep.Type.Int where - -import Binrep.Put.Mason qualified as Mason -import Binrep.Put.Bytezap qualified as Bytezap -import Binrep.Get.Flatparse qualified as Flatparse -import Binrep.BLen.Simple qualified as Simple -import Binrep.CBLen - -import Bytezap.Poke.Int qualified as BZ -import FlatParse.Basic qualified as FP - -import Binrep.Type.Common ( Endianness(..) ) -import Strongweak - -import Data.Word -import Data.Int -import Data.Aeson - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) -import GHC.TypeNats - -import Binrep.Via ( Binreply(..) ) - --- | Machine integer sign. --- --- Signed integers use two's complement for representation. -data ISign - = U -- ^ unsigned - | I -- ^ signed (two's complement) - deriving stock (Generic, Data, Show, Eq) - --- | A type tagged with the endianness (byte order) to use when serializing. --- --- Intended to be used to wrap existing types which do not otherwise expose --- endianness, namely the machine integers 'Int32', 'Word64' etc. As such, it --- derives various relevant type classes using the wrapped type. --- --- May be considered a restricted 'Data.Tagged.Tagged' (from the @tagged@ --- package). -newtype Endian (end :: Endianness) a = Endian - { -- | Discard endianness information. - unEndian :: a } - deriving stock (Generic, Data, Show) - deriving (Eq, Ord, Bounded, Num, Enum, Real, Integral) via a - deriving (IsCBLen, Simple.BLen) via a - deriving (Weaken, Strengthen) via a - deriving (ToJSON, FromJSON) via a - --- | Endianness doesn't matter for single bytes. -deriving via Binreply Word8 instance Mason.Put (Endian end Word8) - --- | Endianness doesn't matter for single bytes. -deriving via Binreply Word8 instance Flatparse.Get (Endian end Word8) - --- | Endianness doesn't matter for single bytes. -deriving via Binreply Int8 instance Mason.Put (Endian end Int8) - --- | Endianness doesn't matter for single bytes. -deriving via Binreply Int8 instance Flatparse.Get (Endian end Int8) - -{- 2023-02-01 raehik: -byteswapping should be faster than poking "backwards" byte by byte. confirmed -with nikita-volkov's ptr-poker package via benchmarks (single operation ~2% -faster) and inspecting disassembly (byteswapX is inlined at the assembly level -as BSWAP, byte by byte takes lots of MOVs and SHRs) - -2023-02-18 raehik: this change is applied to nikita-volkov's ptr-poker pkg :) --} - --- | Ask for a minimum length before running the given parser and wrapping the --- result in 'Endian'. -flatparseParseEndianMin - :: Flatparse.Getter a -> Int -> Flatparse.Getter (Endian end a) -flatparseParseEndianMin f n = - Endian <$> Flatparse.getEBase f (Flatparse.ERanOut n) - -instance Bytezap.Put (Endian 'LE Word16) where put = BZ.w16le . unEndian -instance Flatparse.Get (Endian 'LE Word16) where - get = flatparseParseEndianMin FP.anyWord16le 2 -instance Bytezap.Put (Endian 'BE Word16) where put = BZ.w16be . unEndian -instance Flatparse.Get (Endian 'BE Word16) where - get = flatparseParseEndianMin FP.anyWord16be 2 - -instance Bytezap.Put (Endian 'LE Word32) where put = BZ.w32le . unEndian -instance Flatparse.Get (Endian 'LE Word32) where - get = flatparseParseEndianMin FP.anyWord32le 4 -instance Bytezap.Put (Endian 'BE Word32) where put = BZ.w32be . unEndian -instance Flatparse.Get (Endian 'BE Word32) where - get = flatparseParseEndianMin FP.anyWord32be 4 - -instance Bytezap.Put (Endian 'LE Word64) where put = BZ.w64le . unEndian -instance Flatparse.Get (Endian 'LE Word64) where - get = flatparseParseEndianMin FP.anyWord64le 8 -instance Bytezap.Put (Endian 'BE Word64) where put = BZ.w64be . unEndian -instance Flatparse.Get (Endian 'BE Word64) where - get = flatparseParseEndianMin FP.anyWord64be 8 - -instance Bytezap.Put (Endian 'LE Int16) where put = BZ.i16le . unEndian -instance Flatparse.Get (Endian 'LE Int16) where - get = flatparseParseEndianMin FP.anyInt16le 2 -instance Bytezap.Put (Endian 'BE Int16) where put = BZ.i16be . unEndian -instance Flatparse.Get (Endian 'BE Int16) where - get = flatparseParseEndianMin FP.anyInt16be 2 - -instance Bytezap.Put (Endian 'LE Int32) where put = BZ.i32le . unEndian -instance Flatparse.Get (Endian 'LE Int32) where - get = flatparseParseEndianMin FP.anyInt32le 4 -instance Bytezap.Put (Endian 'BE Int32) where put = BZ.i32be . unEndian -instance Flatparse.Get (Endian 'BE Int32) where - get = flatparseParseEndianMin FP.anyInt32be 4 - -instance Bytezap.Put (Endian 'LE Int64) where put = BZ.i64le . unEndian -instance Flatparse.Get (Endian 'LE Int64) where - get = flatparseParseEndianMin FP.anyInt64le 8 -instance Bytezap.Put (Endian 'BE Int64) where put = BZ.i64be . unEndian -instance Flatparse.Get (Endian 'BE Int64) where - get = flatparseParseEndianMin FP.anyInt64be 8 - --- | Grouping for matching a signedness and size to a Haskell integer data type. -type family IRep (isign :: ISign) (isize :: Natural) where - IRep 'U 8 = Word8 - IRep 'I 8 = Int8 - IRep 'U 16 = Word16 - IRep 'I 16 = Int16 - IRep 'U 32 = Word32 - IRep 'I 32 = Int32 - IRep 'U 64 = Word64 - IRep 'I 64 = Int64 - --- | Largest representable value for a machine integer made of @n@ bits. --- --- If signed ''I', twos complement is used, so negative range has 1 extra value. -type family IMax (isign :: ISign) (n :: Natural) :: Natural where - IMax 'U n = 2^n-1 - IMax 'I n = 2^(n-1) diff --git a/src/Binrep/Type/Magic.hs b/src/Binrep/Type/Magic.hs --- a/src/Binrep/Type/Magic.hs +++ b/src/Binrep/Type/Magic.hs @@ -23,9 +23,10 @@ module Binrep.Type.Magic where import Binrep -import Binrep.Type.Byte +import Bytezap.Struct.TypeLits ( ReifyBytesW64(reifyBytesW64) ) import FlatParse.Basic qualified as FP import Data.ByteString qualified as B +import Util.TypeNats ( natValInt ) import GHC.TypeLits @@ -34,49 +35,52 @@ import Strongweak --- | A singleton data type representing a "magic number" (a constant bytestring) --- via a phantom type. +-- | A singleton data type representing a "magic number" via a phantom type. -- -- The phantom type variable unambiguously defines a constant bytestring. -- A handful of types are supported for using magics conveniently, e.g. for pure -- ASCII magics, you may use a 'Symbol' type-level string. -data Magic (a :: k) = Magic - deriving stock (Generic, Data, Show, Eq) +data Magic (a :: k) = Magic deriving stock (Generic, Data, Show, Eq) --- | Weaken a 'Magic a' to the unit. Perhaps you prefer pattern matching on @()@ --- over @Magic@, or wish a weak type to be fully divorced from its binrep --- origins. +-- | Weaken a @'Magic' a@ to the unit. instance Weaken (Magic a) where type Weak (Magic a) = () weaken Magic = () --- | Strengthen the unit to some 'Magic a'. -instance Strengthen (Magic a) where - strengthen () = pure Magic +-- | Strengthen the unit to some @'Magic' a@. +instance Strengthen (Magic a) where strengthen () = pure Magic +-- | The byte length of a magic is known at compile time. instance IsCBLen (Magic a) where type CBLen (Magic a) = Length (MagicBytes a) -deriving via CBLenly (Magic a) instance + +-- | The byte length of a magic is obtained via reifying. +deriving via ViaCBLen (Magic a) instance KnownNat (Length (MagicBytes a)) => BLen (Magic a) -instance (bs ~ MagicBytes a, ReifyBytes bs) => Put (Magic a) where - put Magic = reifyBytes @bs +instance (bs ~ MagicBytes a, ReifyBytesW64 bs) => PutC (Magic a) where + putC Magic = reifyBytesW64 @bs -instance (bs ~ MagicBytes a, ReifyBytes bs, KnownNat (Length bs)) +deriving via (ViaPutC (Magic a)) instance + (bs ~ MagicBytes a, ReifyBytesW64 bs, KnownNat (Length bs)) => Put (Magic a) + +instance (bs ~ MagicBytes a, ReifyBytesW64 bs, KnownNat (Length bs)) => Get (Magic a) where - -- TODO silly optimization: we _could_ skip comparing BS lengths because we - -- know they have to be the same. lmao get = do -- Nice case where we _want_ flatparse's no-copy behaviour, because -- 'actual' is only in scope for this parser. Except, of course, if we -- error, in which case _now_ we copy. Efficient! - actual <- FP.take (blen magic) + actual <- FP.take (natValInt @(Length bs)) + -- silly optimization: we could skip comparing lengths because we know + -- they must be the same. very silly though if actual == expected - then pure Magic + then pure magic else eBase $ EExpected expected (B.copy actual) where expected = runPut magic magic = Magic :: Magic a +-- TODO might wanna move this +-- | The length of a type-level list. type family Length (a :: [k]) :: Natural where Length '[] = 0 Length (a ': as) = 1 + Length as @@ -116,8 +120,7 @@ type MagicBytes a :: [Natural] -- | Type-level naturals go as-is. (Make sure you don't go over 255, though!) -instance Magical (ns :: [Natural]) where - type MagicBytes ns = ns +instance Magical (ns :: [Natural]) where type MagicBytes ns = ns -- | Type-level symbols are turned into their Unicode codepoints - but -- multibyte characters aren't handled, so they'll simply be overlarge bytes, diff --git a/src/Binrep/Type/NullPadded.hs b/src/Binrep/Type/NullPadded.hs --- a/src/Binrep/Type/NullPadded.hs +++ b/src/Binrep/Type/NullPadded.hs @@ -1,11 +1,15 @@ +-- | Data null-padded to a given length. + {-# LANGUAGE OverloadedStrings #-} module Binrep.Type.NullPadded where import Binrep -import Bytezap.Bytes qualified as BZ +import Bytezap.Poke qualified as BZ +import Bytezap.Struct qualified as BZ.Struct import FlatParse.Basic qualified as FP -import Control.Monad.Combinators qualified as Monad +import Raehik.Compat.FlatParse.Basic.WithLength qualified as FP +import Control.Monad.Combinators ( skipCount ) import Binrep.Util ( tshow ) @@ -48,19 +52,31 @@ n = natValInt @n len = blen a -instance (BLen a, Put a, KnownNat n) => Put (NullPadded n a) where - put ra = put a <> BZ.pokeByteReplicate paddingLen 0x00 +instance IsCBLen (NullPadded n a) where type CBLen (NullPadded n a) = n +deriving via ViaCBLen (NullPadded n a) instance KnownNat n => BLen (NullPadded n a) + +instance (BLen a, KnownNat n, PutC a) => PutC (NullPadded n a) where + putC ra = BZ.Struct.sequencePokes (putC a) len + (BZ.Struct.replicateByte paddingLen 0x00) where + len = blen a a = unrefine ra + paddingLen = natValInt @n - len + -- ^ refinement guarantees >=0 + +instance (BLen a, KnownNat n, Put a) => Put (NullPadded n a) where + put ra = put a <> BZ.replicateByte paddingLen 0x00 + where + a = unrefine ra paddingLen = natValInt @n - blen a -- ^ refinement guarantees >=0 -instance (BLen a, Get a, KnownNat n) => Get (NullPadded n a) where +instance (Get a, KnownNat n) => Get (NullPadded n a) where get = do - a <- get - let paddingLen = natValInt @n - blen a + (a, len) <- FP.parseWithLength get + let paddingLen = natValInt @n - len if paddingLen < 0 then eBase $ EFailNamed "TODO used to be EOverlong, cba" else do - Monad.skipCount paddingLen (FP.word8 0x00) + skipCount paddingLen (FP.word8 0x00) pure $ reallyUnsafeRefine a diff --git a/src/Binrep/Type/NullTerminated.hs b/src/Binrep/Type/NullTerminated.hs --- a/src/Binrep/Type/NullTerminated.hs +++ b/src/Binrep/Type/NullTerminated.hs @@ -11,7 +11,6 @@ import Binrep -import Binrep.Get.Flatparse qualified as Flatparse import FlatParse.Basic qualified as FP import Refined @@ -48,10 +47,10 @@ {-# INLINE put #-} put a = put (unrefine a) <> put @Word8 0x00 --- | Parse a null-terminated bytestring. -instance Flatparse.Get (NullTerminated B.ByteString) where +-- | We may parse any null-terminated data using a special flatparse combinator. +instance Get a => Get (NullTerminated a) where {-# INLINE get #-} - get = reallyUnsafeRefine <$> Flatparse.getEBase FP.anyCString (EFailNamed "cstring") + get = reallyUnsafeRefine <$> getEBase (FP.isolateToNextNull get) (EFailNamed "cstring") {- I don't know how to do @[a]@. Either I nullterm each element, which is weird diff --git a/src/Binrep/Type/Prefix.hs b/src/Binrep/Type/Prefix.hs deleted file mode 100644 --- a/src/Binrep/Type/Prefix.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic - -module Binrep.Type.Prefix where - -import Binrep.Type.Int -import GHC.TypeNats -import Data.Word - -import Data.Kind - --- | Types which may be used as prefixes. --- --- Generally, these will be integer types. --- --- Note that this is separate to binary representation, so endianness is --- irrelevant. --- --- TODO oops can't use 'Int's everywhere because of overflow :'( that's OK -class Prefix a where - type Max a :: Natural - - -- | used by put. guaranteed that it fits from refined. that is, lenToPfx <= - -- Max. - lenToPfx :: Int -> a - - -- | used by get. better not lie. - pfxToLen :: a -> Int - --- | Length prefixing with the unit means a length of 0. --- --- This is the only sensible case. 1 doesn't work because refining checks @<=@. --- --- I think there are laws here, where using this is the same as doing nothing at --- all. -instance Prefix () where - type Max () = 0 - lenToPfx 0 = () - lenToPfx _ = error "you lied to refine and broke everything :(" - pfxToLen () = 0 - -deriving via (a :: Type) instance Prefix a => Prefix (Endian end a) - -instance Prefix Word8 where - type Max Word8 = 2^8 - 1 - lenToPfx = fromIntegral - pfxToLen = fromIntegral -instance Prefix Word16 where - type Max Word16 = 2^16 - 1 - lenToPfx = fromIntegral - pfxToLen = fromIntegral -instance Prefix Word32 where - type Max Word32 = 2^32 - 1 - lenToPfx = fromIntegral - pfxToLen = fromIntegral - --- TODO no instances > Int, since they would break when too large diff --git a/src/Binrep/Type/Prefix/Count.hs b/src/Binrep/Type/Prefix/Count.hs --- a/src/Binrep/Type/Prefix/Count.hs +++ b/src/Binrep/Type/Prefix/Count.hs @@ -3,7 +3,7 @@ module Binrep.Type.Prefix.Count where -import Binrep.Type.Prefix +import Binrep.Util.Prefix import Binrep import Control.Monad.Combinators qualified as Monad @@ -30,10 +30,18 @@ => Predicate (CountPrefix pfx) (f a) where validate = validate1 --- TODO no idea if this is sensible +-- | We can know byte length at compile time _if_ we know it for the prefix and +-- the list-like. +-- +-- This is extremely unlikely, because then what counting are we even +-- performing for the list-like? But it's a valid instance. instance IsCBLen (CountPrefixed pfx f a) where type CBLen (CountPrefixed pfx f a) = CBLen pfx + CBLen (f a) +-- | The byte length of a count-prefixed type is the length of the prefix type +-- (holding the length of the type) plus the length of the type. +-- +-- Bit confusing. How to explain this? TODO instance (Prefix pfx, Foldable f, BLen pfx, BLen (f a)) => BLen (CountPrefixed pfx f a) where blen rfa = blen (lenToPfx @pfx (Foldable.length fa)) + blen fa diff --git a/src/Binrep/Type/Prefix/Size.hs b/src/Binrep/Type/Prefix/Size.hs --- a/src/Binrep/Type/Prefix/Size.hs +++ b/src/Binrep/Type/Prefix/Size.hs @@ -3,7 +3,7 @@ module Binrep.Type.Prefix.Size where -import Binrep.Type.Prefix +import Binrep.Util.Prefix import Binrep.Type.Thin import Binrep import FlatParse.Basic qualified as FP diff --git a/src/Binrep/Type/Sized.hs b/src/Binrep/Type/Sized.hs --- a/src/Binrep/Type/Sized.hs +++ b/src/Binrep/Type/Sized.hs @@ -16,7 +16,7 @@ import GHC.TypeNats import Util.TypeNats ( natValInt ) --- | Essentially reflects a 'BLen' type to 'CBLen'. +-- | Essentially runtime reflection of a 'BLen' type to 'CBLen'. data Size (n :: Natural) type Sized n = Refined (Size n) @@ -31,13 +31,17 @@ len = blen a instance IsCBLen (Sized n a) where type CBLen (Sized n a) = n -deriving via CBLenly (Sized n a) instance KnownNat n => BLen (Sized n a) +deriving via ViaCBLen (Sized n a) instance KnownNat n => BLen (Sized n a) +instance PutC a => PutC (Sized n a) where + putC = putC . unrefine + instance Put a => Put (Sized n a) where put = put . unrefine --- TODO safety: isolate consumes all bytes if succeeds instance (Get a, KnownNat n) => Get (Sized n a) where get = do a <- FP.isolate (natValInt @n) get pure $ reallyUnsafeRefine a + -- ^ REFINE SAFETY: 'FP.isolate' consumes precisely the number of bytes + -- requested when it succeeds diff --git a/src/Binrep/Type/Text/Encoding/Utf16.hs b/src/Binrep/Type/Text/Encoding/Utf16.hs --- a/src/Binrep/Type/Text/Encoding/Utf16.hs +++ b/src/Binrep/Type/Text/Encoding/Utf16.hs @@ -1,7 +1,7 @@ module Binrep.Type.Text.Encoding.Utf16 where import Binrep.Type.Text.Internal -import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Util.ByteOrder import Refined import Data.Typeable ( Typeable ) @@ -9,13 +9,13 @@ import Data.Text.Encoding qualified as Text import Data.Text ( Text ) -data Utf16 (end :: Endianness) +data Utf16 (end :: ByteOrder) -instance Encode (Utf16 'BE) where encode' = Text.encodeUtf16BE -instance Encode (Utf16 'LE) where encode' = Text.encodeUtf16LE +instance Encode (Utf16 BE) where encode' = Text.encodeUtf16BE +instance Encode (Utf16 LE) where encode' = Text.encodeUtf16LE -instance Decode (Utf16 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16BE -instance Decode (Utf16 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16LE +instance Decode (Utf16 BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16BE +instance Decode (Utf16 LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16LE -- | Any 'Text' value is always valid UTF-16. instance Typeable end => Predicate (Utf16 end) Text where validate _ _ = success diff --git a/src/Binrep/Type/Text/Encoding/Utf32.hs b/src/Binrep/Type/Text/Encoding/Utf32.hs --- a/src/Binrep/Type/Text/Encoding/Utf32.hs +++ b/src/Binrep/Type/Text/Encoding/Utf32.hs @@ -1,7 +1,7 @@ module Binrep.Type.Text.Encoding.Utf32 where import Binrep.Type.Text.Internal -import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Util.ByteOrder import Refined import Data.Typeable ( Typeable ) @@ -9,13 +9,13 @@ import Data.Text.Encoding qualified as Text import Data.Text ( Text ) -data Utf32 (end :: Endianness) +data Utf32 (end :: ByteOrder) -instance Encode (Utf32 'BE) where encode' = Text.encodeUtf32BE -instance Encode (Utf32 'LE) where encode' = Text.encodeUtf32LE +instance Encode (Utf32 BE) where encode' = Text.encodeUtf32BE +instance Encode (Utf32 LE) where encode' = Text.encodeUtf32LE -instance Decode (Utf32 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32BE -instance Decode (Utf32 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32LE +instance Decode (Utf32 BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32BE +instance Decode (Utf32 LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32LE -- | Any 'Text' value is always valid UTF-32. instance Typeable end => Predicate (Utf32 end) Text where validate _ _ = success diff --git a/src/Binrep/Type/Thin.hs b/src/Binrep/Type/Thin.hs --- a/src/Binrep/Type/Thin.hs +++ b/src/Binrep/Type/Thin.hs @@ -25,8 +25,6 @@ import Binrep import FlatParse.Basic qualified as FP -import Bytezap qualified as BZ -import Bytezap.Bytes qualified as BZ import GHC.Generics ( Generic ) import Data.Data ( Data ) @@ -51,5 +49,3 @@ deriving (Weaken, Strengthen) via Identity a instance Get (Thin B.ByteString) where get = Thin <$> FP.takeRest -instance Get (Thin BZ.Write) where - get = fmap Thin $ fmap BZ.byteString $ FP.takeRest diff --git a/src/Binrep/Util/ByteOrder.hs b/src/Binrep/Util/ByteOrder.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/ByteOrder.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Binrep.Util.ByteOrder + ( ByteOrder(..), ByteOrdered(..) + , type LE, type BE, type Endian + ) where + +import Raehik.Compat.Data.Primitive.Types.Endian ( ByteOrdered(..) ) +import GHC.ByteOrder ( ByteOrder(..) ) +import Strongweak +import Data.Kind ( Type ) + +deriving via (a :: Type) instance Weaken a => Weaken (ByteOrdered end a) +deriving via (a :: Type) instance Strengthen a => Strengthen (ByteOrdered end a) + +-- shorter names I originally used +type LE = 'LittleEndian +type BE = 'BigEndian +type Endian = ByteOrdered diff --git a/src/Binrep/Util/Class.hs b/src/Binrep/Util/Class.hs deleted file mode 100644 --- a/src/Binrep/Util/Class.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Binrep.Util.Class where - -import GHC.TypeLits - --- | Common type error string for when you attempt to use a binrep instance at --- an empty data type (e.g. 'Data.Void.Void', 'GHC.Generics.V1'). -type ENoEmpty = 'Text "No binary representation for empty data type" - --- | Common type error string for when you attempt to use a binrep instance --- at a sum data type --- GHC is asked to derive a non-sum --- instance, but the data type in question turns out to be a sum data type. --- --- No need to add the data type name here, since GHC's context includes the --- surrounding instance declaration. -type ENoSum = - 'Text "No binary representation for unannotated sum data type" - :$$: 'Text "Consider defining a custom data type" - :<>: 'Text " and deriving a generic instance with explicit sum handling" diff --git a/src/Binrep/Util/Prefix.hs b/src/Binrep/Util/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/Prefix.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic + +module Binrep.Util.Prefix where + +import Binrep.Util.ByteOrder ( ByteOrdered(ByteOrdered) ) +import GHC.TypeNats +import Data.Word + +import Data.Kind + +-- | Types which may be used as prefixes. +-- +-- Generally, these will be integer types. +-- +-- Note that this is separate to binary representation, so endianness is +-- irrelevant. +-- +-- Note that we are also limited by the host architecture's 'Int' type. +-- We don't try to work around this, because most types are indexed with 'Int's, +-- so I think other things will break before we do. +class Prefix a where + type Max a :: Natural + + -- | used by put. guaranteed that it fits from refined. that is, lenToPfx <= + -- Max. + lenToPfx :: Int -> a + + -- | used by get. better not lie. + pfxToLen :: a -> Int + +-- | Length prefixing with the unit means a length of 0. +-- +-- This is the only sensible case. 1 doesn't work because refining checks @<=@. +-- +-- I think there are laws here, where using this is the same as doing nothing at +-- all. +instance Prefix () where + type Max () = 0 + lenToPfx = \case + 0 -> () + _ -> error "you lied to refine and broke everything :(" + pfxToLen () = 0 + +-- | Byte ordering doesn't change how prefixes work. +deriving via (a :: Type) instance Prefix a => Prefix (ByteOrdered end a) + +instance Prefix Word8 where + type Max Word8 = 2^8 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral +instance Prefix Word16 where + type Max Word16 = 2^16 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral +instance Prefix Word32 where + type Max Word32 = 2^32 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral +instance Prefix Word64 where + type Max Word64 = 2^64 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral diff --git a/src/Binrep/Via.hs b/src/Binrep/Via.hs deleted file mode 100644 --- a/src/Binrep/Via.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Binrep.Via where - -import Binrep.CBLen qualified as BR -import Binrep.BLen.Simple qualified as BR.Simple -import Binrep.Put.Mason qualified as BR.Mason -import Binrep.Put.Bytezap qualified as BR.Bytezap -import Binrep.Get.Flatparse qualified as BR.Flatparse - --- | Identity newtype for using with @DerivingVia@. -newtype Binreply a = Binreply { unBinreply :: a } - deriving stock Show - deriving (BR.IsCBLen, BR.Simple.BLen, BR.Mason.Put, BR.Bytezap.Put, BR.Flatparse.Get) via a diff --git a/src/Bytezap.hs b/src/Bytezap.hs deleted file mode 100644 --- a/src/Bytezap.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} - -module Bytezap where - -import GHC.Exts -import Data.ByteString qualified as B -import Data.ByteString.Internal qualified as B -import GHC.IO -import Data.Word - --- | TODO inner poke type --- --- TODO can I change this to --- --- @ --- Ptr Word8 -> IO (Ptr Word8) --- @ --- --- without any performance loss? it's the same underneath newtypes and datas. --- 'Ptr' is a data rather than a newtype, but IO is just a newtype. --- --- I originally did this to beat ptr-poker, but idk. Now doubtful. -type Poke# = Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) - --- | Unboxed poke operation. --- --- A newtype allows us a monoidal interface. -newtype Poke = Poke - { -- | Write at an offset from an address and return the next offset. - -- - -- The returned offset must be after the argument offset. - -- - -- TODO I use that output order because it matches IO. Probs doesn't matter. - unPoke :: Poke# - } - --- | Construct a 'Poke'. -poke :: Poke# -> Poke -poke = Poke -{-# INLINE poke #-} - --- | Sequence two 'Poke's left-to-right. -instance Semigroup Poke where - {-# INLINE (<>) #-} - Poke l <> Poke r = Poke $ \addr# st# -> - case l addr# st# of (# st'#, addr'# #) -> r addr'# st'# - --- | The empty 'Poke' simply returns its arguments. -instance Monoid Poke where - {-# INLINE mempty #-} - mempty = Poke $ \addr# st# -> (# st#, addr# #) - --- | Allocate a buffer of the given size and run a 'Poke' over it. --- --- The 'Poke' must fill the buffer exactly. If it goes under, you should get --- some random garbage at the end. If it goes over, your computer will probably --- explode. -runPoke :: Int -> Poke -> B.ByteString -runPoke len = B.unsafeCreate len . wrapPoke -{-# INLINE runPoke #-} - -wrapPoke :: Poke -> Ptr Word8 -> IO () -wrapPoke (Poke p) (Ptr addr#) = - IO (\st# -> case p addr# st# of (# l, _r #) -> (# l, () #)) -{-# INLINE wrapPoke #-} - --- | Instructions on how to perform a sized write. --- --- The 'Poke' in 'writePoke' must write the _exact_ number of bytes specified in --- 'writeSize'. Otherwise, your computer explodes. -data Write = Write - { writeSize :: {-# UNPACK #-} !Int - , writePoke :: !Poke -- unpack unusable TODO is strict good or not here - } - --- | Construct a 'Write'. -write :: Int -> Poke# -> Write -write len p = Write len (Poke p) -{-# INLINE write #-} - --- | Sequence the 'Poke's, sum the sizes. -instance Semigroup Write where - -- TODO feels like this might be INLINE[1] or even INLINE[0]? - {-# INLINE (<>) #-} - Write ll lp <> Write rl rp = Write (ll + rl) (lp <> rp) - --- | The empty 'Write' is the empty 'Poke', which writes zero bytes. -instance Monoid Write where - {-# INLINE mempty #-} - mempty = Write 0 mempty - --- | Serialize and show the resulting ByteString. -instance Show Write where showsPrec p = showsPrec p . runWrite - -runWrite :: Write -> B.ByteString -runWrite (Write len p) = runPoke len p -{-# INLINE runWrite #-} diff --git a/src/Bytezap/Bytes.hs b/src/Bytezap/Bytes.hs deleted file mode 100644 --- a/src/Bytezap/Bytes.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | 'ByteString's and primitive byte arrays. - -{-# LANGUAGE UnboxedTuples #-} - -module Bytezap.Bytes where - -import Bytezap - -import GHC.Exts -import Data.ByteString qualified as B -import Data.ByteString.Internal qualified as B -import GHC.IO -import Data.Word -import Foreign.ForeignPtr - -byteString :: B.ByteString -> Write -byteString (B.BS fptr len) = Write len (pokeForeignPtr fptr len) -{-# INLINE byteString #-} - -pokeForeignPtr :: ForeignPtr Word8 -> Int -> Poke -pokeForeignPtr fptr len@(I# len#) = poke $ \addr# st# -> - case unIO (memcpyForeignPtr (Ptr addr#) fptr len) st# of - (# st'#, () #) -> (# st'#, addr# `plusAddr#` len# #) -{-# INLINE pokeForeignPtr #-} - -memcpyForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () -memcpyForeignPtr ptrTo fptrFrom len = - B.unsafeWithForeignPtr fptrFrom $ \ptrFrom -> B.memcpy ptrTo ptrFrom len -{-# INLINE memcpyForeignPtr #-} - -pokeByteArray# :: ByteArray# -> Int# -> Int# -> Poke -pokeByteArray# arr# off# len# = poke $ \addr# st# -> - case copyByteArrayToAddr# arr# off# addr# len# st# of - st'# -> (# st'#, addr# `plusAddr#` len# #) -{-# INLINE pokeByteArray# #-} - --- TODO this seems to work but like, really? wow lol -pokeByteReplicate :: Int -> Word8 -> Poke -pokeByteReplicate n@(I# n#) w8 = poke $ \addr# st# -> - case unIO (B.memset (Ptr addr#) w8 (fromIntegral n)) st# of - (# st'#, _ #) -> (# st'#, addr# `plusAddr#` n# #) diff --git a/src/Bytezap/Class.hs b/src/Bytezap/Class.hs deleted file mode 100644 --- a/src/Bytezap/Class.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Bytezap.Class where - -import Bytezap -import Bytezap.Bytes qualified as W -import Bytezap.Int qualified as W - -import Data.ByteString ( ByteString ) -import Data.Word -import Data.Int - -class Put a where put :: a -> Write - -instance Put Write where - {-# INLINE put #-} - put = id - -instance Put ByteString where - {-# INLINE put #-} - put = W.byteString - -instance Put Word8 where - {-# INLINE put #-} - put = W.w8 - -instance Put Word16 where - {-# INLINE put #-} - put = W.w16 - -instance Put Word32 where - {-# INLINE put #-} - put = W.w32 - -instance Put Word64 where - {-# INLINE put #-} - put = W.w64 - -instance Put Int8 where - {-# INLINE put #-} - put = W.i8 - -instance Put Int16 where - {-# INLINE put #-} - put = W.i16 - -instance Put Int32 where - {-# INLINE put #-} - put = W.i32 - -instance Put Int64 where - {-# INLINE put #-} - put = W.i64 diff --git a/src/Bytezap/Int.hs b/src/Bytezap/Int.hs deleted file mode 100644 --- a/src/Bytezap/Int.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | Sized machine integers. - -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -module Bytezap.Int where - -import Bytezap ---import Bytezap.Prim.Integer qualified as Prim -import GHC.Exts -import Data.Word -import GHC.Word -import Data.Int -import GHC.Int - -w8 :: Word8 -> Write -w8 (W8# a#) = write 1 $ \addr# st# -> - case writeWord8OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 1# #) -{-# INLINE w8 #-} - -w16 :: Word16 -> Write -w16 (W16# a#) = write 2 $ \addr# st# -> - case writeWord16OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 2# #) -{-# INLINE w16 #-} - -w32 :: Word32 -> Write -w32 (W32# a#) = write 4 $ \addr# st# -> - case writeWord32OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 4# #) -{-# INLINE w32 #-} - -w64 :: Word64 -> Write -w64 (W64# a#) = write 8 $ \addr# st# -> - case writeWord64OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE w64 #-} - -{-# INLINE w16le #-} -{-# INLINE w16be #-} -w16le, w16be :: Word16 -> Write -#ifdef WORDS_BIGENDIAN -w16le = w16 . byteSwap16 -w16be = w16 -#else -w16le = w16 -w16be = w16 . byteSwap16 -#endif - -{-# INLINE w32le #-} -{-# INLINE w32be #-} -w32le, w32be :: Word32 -> Write -#ifdef WORDS_BIGENDIAN -w32le = w32 . byteSwap32 -w32be = w32 -#else -w32le = w32 -w32be = w32 . byteSwap32 -#endif - -{-# INLINE w64le #-} -{-# INLINE w64be #-} -w64le, w64be :: Word64 -> Write -#ifdef WORDS_BIGENDIAN -w64le = w64 . byteSwap64 -w64be = w64 -#else -w64le = w64 -w64be = w64 . byteSwap64 -#endif - -i8 :: Int8 -> Write -i8 (I8# a#) = write 1 $ \addr# st# -> - case writeInt8OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 1# #) -{-# INLINE i8 #-} - -i16 :: Int16 -> Write -i16 (I16# a#) = write 2 $ \addr# st# -> - case writeInt16OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 2# #) -{-# INLINE i16 #-} - -i32 :: Int32 -> Write -i32 (I32# a#) = write 4 $ \addr# st# -> - case writeInt32OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 4# #) -{-# INLINE i32 #-} - -i64 :: Int64 -> Write -i64 (I64# a#) = write 8 $ \addr# st# -> - case writeInt64OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE i64 #-} - -byteSwapI16 :: Int16 -> Int16 -byteSwapI16 = undefined - -byteSwapI32 :: Int32 -> Int32 -byteSwapI32 = undefined - -byteSwapI64 :: Int64 -> Int64 -byteSwapI64 = undefined - -{-# INLINE i16le #-} -{-# INLINE i16be #-} -i16le, i16be :: Int16 -> Write -#ifdef WORDS_BIGENDIAN -i16le = i16 . byteSwapI16 -i16be = i16 -#else -i16le = i16 -i16be = i16 . byteSwapI16 -#endif - -{-# INLINE i32le #-} -{-# INLINE i32be #-} -i32le, i32be :: Int32 -> Write -#ifdef WORDS_BIGENDIAN -i32le = i32 . byteSwapI32 -i32be = i32 -#else -i32le = i32 -i32be = i32 . byteSwapI32 -#endif - -{-# INLINE i64le #-} -{-# INLINE i64be #-} -i64le, i64be :: Int64 -> Write -#ifdef WORDS_BIGENDIAN -i64le = i64 . byteSwapI64 -i64be = i64 -#else -i64le = i64 -i64be = i64 . byteSwapI64 -#endif - --- TODO assumes 64-bit -int# :: Int# -> Write -int# a# = write 8 $ \addr# st# -> - case writeIntOffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE int# #-} - -{- - --- | Construct a 'Write' of the following length using the given primitive poke. -writeViaPrim - :: Int# - -> (forall s. Addr# -> Int# -> a -> State# s -> State# s) - -> a -> Write -writeViaPrim len# writeOffPrim a = write (I# len#) $ \addr# os# st# -> - case writeOffPrim addr# os# a st# of - st'# -> (# st'#, os# +# len# #) -{-# INLINE writeViaPrim #-} - --} diff --git a/src/Bytezap/Poke/Bytes.hs b/src/Bytezap/Poke/Bytes.hs deleted file mode 100644 --- a/src/Bytezap/Poke/Bytes.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} - -module Bytezap.Poke.Bytes where - -import Bytezap - -import GHC.Exts -import Data.ByteString qualified as B -import Data.ByteString.Internal qualified as B -import GHC.IO -import Data.Word -import Foreign.ForeignPtr - -byteString :: B.ByteString -> Poke -byteString (B.BS fptr len) = pokeForeignPtr fptr len -{-# INLINE byteString #-} - -pokeForeignPtr :: ForeignPtr Word8 -> Int -> Poke -pokeForeignPtr fptr len@(I# len#) = poke $ \addr# st# -> - case unIO (memcpyForeignPtr (Ptr addr#) fptr len) st# of - (# st'#, () #) -> (# st'#, addr# `plusAddr#` len# #) -{-# INLINE pokeForeignPtr #-} - -memcpyForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () -memcpyForeignPtr ptrTo fptrFrom len = - B.unsafeWithForeignPtr fptrFrom $ \ptrFrom -> B.memcpy ptrTo ptrFrom len -{-# INLINE memcpyForeignPtr #-} - -pokeByteArray# :: ByteArray# -> Int# -> Int# -> Poke -pokeByteArray# arr# off# len# = poke $ \addr# st# -> - case copyByteArrayToAddr# arr# off# addr# len# st# of - st'# -> (# st'#, addr# `plusAddr#` len# #) -{-# INLINE pokeByteArray# #-} diff --git a/src/Bytezap/Poke/Int.hs b/src/Bytezap/Poke/Int.hs deleted file mode 100644 --- a/src/Bytezap/Poke/Int.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -module Bytezap.Poke.Int where - -import Bytezap -import GHC.Exts -import Data.Word -import GHC.Word -import Data.Int -import GHC.Int - -w8 :: Word8 -> Poke -w8 (W8# a#) = Poke $ \addr# st# -> - case writeWord8OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 1# #) -{-# INLINE w8 #-} - -w16 :: Word16 -> Poke -w16 (W16# a#) = Poke $ \addr# st# -> - case writeWord16OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 2# #) -{-# INLINE w16 #-} - -w32 :: Word32 -> Poke -w32 (W32# a#) = Poke $ \addr# st# -> - case writeWord32OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 4# #) -{-# INLINE w32 #-} - -w64 :: Word64 -> Poke -w64 (W64# a#) = Poke $ \addr# st# -> - case writeWord64OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE w64 #-} - -{-# INLINE w16le #-} -{-# INLINE w16be #-} -w16le, w16be :: Word16 -> Poke -#ifdef WORDS_BIGENDIAN -w16le = w16 . byteSwap16 -w16be = w16 -#else -w16le = w16 -w16be = w16 . byteSwap16 -#endif - -{-# INLINE w32le #-} -{-# INLINE w32be #-} -w32le, w32be :: Word32 -> Poke -#ifdef WORDS_BIGENDIAN -w32le = w32 . byteSwap32 -w32be = w32 -#else -w32le = w32 -w32be = w32 . byteSwap32 -#endif - -{-# INLINE w64le #-} -{-# INLINE w64be #-} -w64le, w64be :: Word64 -> Poke -#ifdef WORDS_BIGENDIAN -w64le = w64 . byteSwap64 -w64be = w64 -#else -w64le = w64 -w64be = w64 . byteSwap64 -#endif - -i8 :: Int8 -> Poke -i8 (I8# a#) = Poke $ \addr# st# -> - case writeInt8OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 1# #) -{-# INLINE i8 #-} - -i16 :: Int16 -> Poke -i16 (I16# a#) = Poke $ \addr# st# -> - case writeInt16OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 2# #) -{-# INLINE i16 #-} - -i32 :: Int32 -> Poke -i32 (I32# a#) = Poke $ \addr# st# -> - case writeInt32OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 4# #) -{-# INLINE i32 #-} - -i64 :: Int64 -> Poke -i64 (I64# a#) = Poke $ \addr# st# -> - case writeInt64OffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE i64 #-} - -byteSwapI16 :: Int16 -> Int16 -byteSwapI16 = undefined - -byteSwapI32 :: Int32 -> Int32 -byteSwapI32 = undefined - -byteSwapI64 :: Int64 -> Int64 -byteSwapI64 = undefined - -{-# INLINE i16le #-} -{-# INLINE i16be #-} -i16le, i16be :: Int16 -> Poke -#ifdef WORDS_BIGENDIAN -i16le = i16 . byteSwapI16 -i16be = i16 -#else -i16le = i16 -i16be = i16 . byteSwapI16 -#endif - -{-# INLINE i32le #-} -{-# INLINE i32be #-} -i32le, i32be :: Int32 -> Poke -#ifdef WORDS_BIGENDIAN -i32le = i32 . byteSwapI32 -i32be = i32 -#else -i32le = i32 -i32be = i32 . byteSwapI32 -#endif - -{-# INLINE i64le #-} -{-# INLINE i64be #-} -i64le, i64be :: Int64 -> Poke -#ifdef WORDS_BIGENDIAN -i64le = i64 . byteSwapI64 -i64be = i64 -#else -i64le = i64 -i64be = i64 . byteSwapI64 -#endif - --- TODO assumes 64-bit -int# :: Int# -> Poke -int# a# = Poke $ \addr# st# -> - case writeIntOffAddr# addr# 0# a# st# of - st'# -> (# st'#, addr# `plusAddr#` 8# #) -{-# INLINE int# #-} diff --git a/src/Bytezap/Text.hs b/src/Bytezap/Text.hs deleted file mode 100644 --- a/src/Bytezap/Text.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -module Bytezap.Text where - -import Bytezap -import Bytezap.Int - -import Data.Text.Internal - --- unused import warnings due to messy CPP -import Bytezap.Bytes -import Data.Text.Array qualified as A -import GHC.Exts - -import Data.Char ( ord ) -import Data.Foldable ( foldl' ) -import Data.Bits ( shiftR, (.&.) ) - -textUtf8 :: Text -> Write -{-# INLINE textUtf8 #-} -#if MIN_VERSION_text(2,0,0) -textUtf8 (Text (A.ByteArray arr#) (I# off#) len@(I# len#)) = - Write len $ pokeByteArray# arr# off# len# -#else -textUtf8 = error "Bytezap.Text.textUtf8: cba for text-1" -#endif - --- TODO adapted from utf8-string -charUtf8 :: Char -> Write -charUtf8 = go . ord - where - go oc - | oc <= 0x7f = w8 $ fromIntegral oc - - | oc <= 0x7ff = w8 (fromIntegral (0xc0 + (oc `shiftR` 6))) - <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) - - | oc <= 0xffff = w8 (fromIntegral (0xe0 + (oc `shiftR` 12))) - <> w8 (fromIntegral (0x80 + ((oc `shiftR` 6) .&. 0x3f))) - <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) - | otherwise = w8 (fromIntegral (0xf0 + (oc `shiftR` 18))) - <> w8 (fromIntegral (0x80 + ((oc `shiftR` 12) .&. 0x3f))) - <> w8 (fromIntegral (0x80 + ((oc `shiftR` 6) .&. 0x3f))) - <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) -{-# INLINE charUtf8 #-} - --- | TODO --- --- In a perfect world, functions like this would not exist. But this is not a --- perfect world. 'String's suck for a number of reasons. One big one is that --- they are horrendous to serialize. Worse, as of GHC 9.6, type-level strings --- only reflect to 'String'. This function does the best it can to efficiently --- serialize 'String's. It would be much easier and probably similarly fast to --- go through 'Text' instead, but who doesn't like a little challenge? -stringUtf8 :: String -> Write -stringUtf8 = foldl' (\w c -> w <> charUtf8 c) mempty -{-# INLINE stringUtf8 #-} diff --git a/src/Data/Aeson/Extra/SizedVector.hs b/src/Data/Aeson/Extra/SizedVector.hs deleted file mode 100644 --- a/src/Data/Aeson/Extra/SizedVector.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.Aeson.Extra.SizedVector() where - -import Data.Aeson -import Data.Vector.Generic.Sized.Internal qualified as VSI -import Data.Vector.Generic.Sized qualified as VS -import Data.Vector.Generic qualified as V -import GHC.TypeNats ( KnownNat ) - -instance ToJSON (v a) => ToJSON (VSI.Vector v n a) where - toJSON (VSI.Vector v) = toJSON v - toEncoding (VSI.Vector v) = toEncoding v -instance (FromJSON (v a), KnownNat n, V.Vector v a) => FromJSON (VSI.Vector v n a) where - parseJSON j = do - v <- parseJSON j - case VS.toSized v of - Nothing -> fail "TODO bad size" - Just v' -> pure v' diff --git a/src/Raehik/Compat/FlatParse/Basic/Prim.hs b/src/Raehik/Compat/FlatParse/Basic/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/Prim.hs @@ -0,0 +1,11 @@ +module Raehik.Compat.FlatParse.Basic.Prim where + +import Raehik.Compat.Data.Primitive.Types +import FlatParse.Basic +import GHC.Exts ( plusAddr# ) + +anyPrim :: forall a e st. Prim' a => ParserT st e a +anyPrim = withEnsure# size# $ ParserT $ \_fp _eob buf st -> + OK# st (indexWord8OffAddrAs# buf 0#) (buf `plusAddr#` size#) + where + size# = sizeOf# (undefined :: a) diff --git a/src/Raehik/Compat/FlatParse/Basic/WithLength.hs b/src/Raehik/Compat/FlatParse/Basic/WithLength.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/WithLength.hs @@ -0,0 +1,15 @@ +-- | https://github.com/AndrasKovacs/flatparse/pull/56 +module Raehik.Compat.FlatParse.Basic.WithLength where + +import FlatParse.Basic.Parser +import GHC.Exts + +-- | Run a parser, and return the result as well as the number of bytes it +-- consumed. +parseWithLength :: ParserT st e a -> ParserT st e (a, Int) +parseWithLength (ParserT f) = ParserT $ \fp eob s st -> do + case f fp eob s st of + Fail# st' -> Fail# st' + Err# st' e -> Err# st' e + OK# st' a s' -> OK# st' (a, I# (s' `minusAddr#` s)) s' +{-# inline parseWithLength #-} diff --git a/src/Util/TypeNats.hs b/src/Util/TypeNats.hs --- a/src/Util/TypeNats.hs +++ b/src/Util/TypeNats.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- for my TypeApplications-based natVals +{-# LANGUAGE UndecidableInstances #-} -- for Length type family -- | Handy typenat utils. module Util.TypeNats where -- natVal'' -import GHC.TypeNats ( Natural, KnownNat, natVal' ) +import GHC.TypeNats ( Natural, KnownNat, natVal', type (+) ) import GHC.Exts ( proxy#, Proxy# ) natVal'' :: forall n. KnownNat n => Natural @@ -16,3 +17,8 @@ natValInt = fromIntegral $ natVal'' @n {-# INLINE natValInt #-} +-- TODO might wanna move this +-- | The length of a type-level list. +type family Length (a :: [k]) :: Natural where + Length '[] = 0 + Length (a ': as) = 1 + Length as diff --git a/test/ArbitraryOrphans.hs b/test/ArbitraryOrphans.hs --- a/test/ArbitraryOrphans.hs +++ b/test/ArbitraryOrphans.hs @@ -3,9 +3,9 @@ module ArbitraryOrphans() where import Test.QuickCheck ( Arbitrary ) -import Binrep.Type.Int -import Data.Kind +import Binrep.Util.ByteOrder ( ByteOrdered(..) ) +import Data.Kind ( Type ) -- TODO 2023-01-26 raehik: why does the following crash GHC -deriving via (a :: Type) instance Arbitrary a => Arbitrary (Endian end a) +deriving via (a :: Type) instance Arbitrary a => Arbitrary (ByteOrdered end a) --deriving newtype instance Arbitrary a => Arbitrary (Endian end a) diff --git a/test/Binrep/Extra/HexByteStringSpec.hs b/test/Binrep/Extra/HexByteStringSpec.hs deleted file mode 100644 --- a/test/Binrep/Extra/HexByteStringSpec.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Binrep.Extra.HexByteStringSpec ( spec ) where - -import Binrep.Extra.HexByteString -import Test.Hspec - -import Data.ByteString qualified as B -import Text.Megaparsec -import Data.Void ( Void ) - -megaparsecParseFromCharStream :: forall s a. (Stream s, Token s ~ Char) => Parsec Void s a -> s -> Maybe a -megaparsecParseFromCharStream parser text = parseMaybe parser text - -spec :: Spec -spec = do - let bs = B.pack - describe "parse" $ do - let p = megaparsecParseFromCharStream @String (parseHexByteString B.pack) - it "parses valid hex bytestrings" $ do - p "00" `shouldBe` Just (bs [0x00]) - p "FF" `shouldBe` Just (bs [0xFF]) - p "1234" `shouldBe` Just (bs [0x12, 0x34]) - p "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE]) - p "FFFFFFFF" `shouldBe` Just (B.replicate 4 0xFF) - p "12 34 AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD]) - it "fails to parse invalid hex bytestrings" $ do - p "-00" `shouldBe` Nothing - p "FG" `shouldBe` Nothing - it "fails to parse 0x prefix" $ do - p "1234" `shouldBe` Just (bs [0x12, 0x34]) - p "0x1234" `shouldBe` Nothing - describe "print" $ do - it "prints pretty hex bytestrings" $ do - let p = prettyHexByteString B.unpack - p (bs [0x5a, 0x7d]) `shouldBe` "5A 7D" - it "prints compact hex bytestrings" $ do - let pc = prettyHexByteStringCompact B.unpack - pc (bs [0xab, 0x25]) `shouldBe` "ab25" diff --git a/test/Binrep/LawsSpec.hs b/test/Binrep/LawsSpec.hs --- a/test/Binrep/LawsSpec.hs +++ b/test/Binrep/LawsSpec.hs @@ -11,10 +11,7 @@ import Binrep import Binrep.Generic ( nullTermCstrPfxTag ) -import Binrep.BLen.Simple ( blenGenericNonSum, blenGenericSum ) -import Binrep.Type.Int -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.NullTerminated +import Binrep.Util.ByteOrder import Data.Word import Data.ByteString qualified as B import GHC.Generics ( Generic ) @@ -33,8 +30,8 @@ -------------------------------------------------------------------------------- type W1 = Word8 -type W2LE = Endian 'LE Word16 -type W8BE = Endian 'BE Word64 +type W2LE = ByteOrdered LE Word16 +type W8BE = ByteOrdered BE Word64 data D = D01Bla Word8 W1 W8BE