diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## 0.8.0 (2024-04-13) +* add missing `And` predicate combinators instances (`PutC`, `GetC`) +* add `Type.Derived.NullTermPadded` (type synonym over `And`) +* add `Generically` instances for `PutC` and `GetC`, where only non-sums are + permitted +* add `GenericallyNonSum` newtype wrapper +* `Magic (a :: Symbol)` now supports UTF-8 symbols instead of just ASCII. All + work is still done on the type-level. + ## 0.7.0 (2024-04-10) * provide "C struct" parser (from bytezap) * fill out some missing C struct instances diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,9 @@ -[gh-strongweak]: https://github.com/raehik/strongweak -[gh-flatparse]: https://github.com/AndrasKovacs/flatparse -[gh-mason]: https://github.com/fumieval/mason -[gh-refined]: https://github.com/nikita-volkov/refined +[gh-strongweak]: https://github.com/raehik/strongweak +[gh-flatparse]: https://github.com/AndrasKovacs/flatparse +[gh-mason]: https://github.com/fumieval/mason +[gh-refined]: https://github.com/nikita-volkov/refined +[hackage-gdf]: https://hackage.haskell.org/package/generic-data-functions +[hackage-bytezap]: https://hackage.haskell.org/package/bytezap # binrep binrep is a Haskell library for *precisely modelling binary schemas*, especially @@ -12,16 +14,14 @@ Use highly parameterized binary representation primitives including null-terminated data (e.g. C-style strings), Pascal-style data (length prefixed), sized explicit-endian machine integers, null-padded data. Write - your own as needed. - * **Low boilerplate:** Straightforward schemas can leverage efficient generic - parsers and serializers with just a few lines. (See [Generic binary - representation](#generic-binary-representation) for details.) + your own primitives if you want (if so, please consider making a PR!). + * **Low boilerplate:** Free performant parsers and serializers via generics. + _(See [Generic binary representation](#generic-binary-representation).)_ * **Easy validation:** Use the [strongweak][gh-strongweak] library design pattern to define an unvalidated data type for easy internal transformation, and get validation code for free. * **Performant:** Parsing and serialization is *extremely fast*, using - [flatparse][gh-flatparse] and [mason][gh-mason] respectively. An - experimental non-allocating serializer is also provided. + [bytezap][hackage-bytezap] and [flatparse][gh-flatparse]. ## Usage ### Dependencies @@ -66,19 +66,10 @@ supporting definitions for this pattern, and generic derivers which will work with binrep's binary representation primitives. -### Performant primitives -Parsing uses András Kovács' [flatparse][gh-flatparse] library. Serializing is -via Fumiaki Kinoshita's [mason][gh-mason] library. These are about as fast as -you can get in 2022. - -We only define serializers for validated types, meaning we can potentially skip -safety checks, that other serializers would do. Except we still do them, but -validation is an explicitly required step before serialization. - -*This might change if we start to support weirder binary representations, -specifically offset-based data.* - ## Generic binary representation +_(Generics are now handled by [generic-data-functions][hackage-gdf]. This info +is largely the same, but the code is elsewhere.)_ + binrep's generic deriving makes very few decisions: * Constructors are encoded by sequentially encoding every enclosed field. diff --git a/binrep.cabal b/binrep.cabal --- a/binrep.cabal +++ b/binrep.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: binrep -version: 0.7.0 +version: 0.8.0 synopsis: Encode precise binary representations directly in types description: Please see README.md. category: Data, Serialization, Generics @@ -36,8 +36,8 @@ Binrep Binrep.BLen Binrep.CBLen - Binrep.CBLen.Generic Binrep.Common.Class.TypeErrors + Binrep.Common.Via.Generically.NonSum Binrep.Common.Via.Prim Binrep.Generic Binrep.Get @@ -46,6 +46,7 @@ Binrep.Put Binrep.Put.Struct Binrep.Test + Binrep.Type.Derived.NullTermPadded Binrep.Type.Magic Binrep.Type.NullPadded Binrep.Type.NullTerminated @@ -86,16 +87,18 @@ build-depends: base >=4.14 && <5 , bytestring >=0.11 && <0.13 - , bytezap >=1.1.0 && <1.2 + , bytezap >=1.2.0 && <1.3 , deepseq >=1.4.6.1 && <1.6 , defun-core ==0.1.* , flatparse >=0.5.0.2 && <0.6 , generic-data-functions >=0.5.0 && <0.6 , generic-type-asserts >=0.3.0 && <0.4 + , generic-type-functions >=0.1.0 && <0.2 , parser-combinators >=1.3.0 && <1.4 , refined1 ==0.9.* , strongweak >=0.6.0 && <0.7 , text >=1.2.5.0 && <2.1 + , type-level-bytestrings >=0.1.0 && <0.2 default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU @@ -130,19 +133,21 @@ , base >=4.14 && <5 , binrep , bytestring >=0.11 && <0.13 - , bytezap >=1.1.0 && <1.2 + , bytezap >=1.2.0 && <1.3 , deepseq >=1.4.6.1 && <1.6 , defun-core ==0.1.* , flatparse >=0.5.0.2 && <0.6 , generic-data-functions >=0.5.0 && <0.6 , generic-random >=1.5.0.1 && <1.6 , generic-type-asserts >=0.3.0 && <0.4 + , generic-type-functions >=0.1.0 && <0.2 , hspec >=2.7 && <2.12 , 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 + , type-level-bytestrings >=0.1.0 && <0.2 default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU @@ -172,17 +177,19 @@ base >=4.14 && <5 , binrep , bytestring >=0.11 && <0.13 - , bytezap >=1.1.0 && <1.2 + , bytezap >=1.2.0 && <1.3 , deepseq >=1.4.6.1 && <1.6 , defun-core ==0.1.* , flatparse >=0.5.0.2 && <0.6 , gauge , generic-data-functions >=0.5.0 && <0.6 , generic-type-asserts >=0.3.0 && <0.4 + , generic-type-functions >=0.1.0 && <0.2 , parser-combinators >=1.3.0 && <1.4 , refined1 ==0.9.* , strongweak >=0.6.0 && <0.7 , text >=1.2.5.0 && <2.1 + , type-level-bytestrings >=0.1.0 && <0.2 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,5 +1,25 @@ +{- | Top-level binrep module, exporting all classes, generics & runners. + +binrep helps you precisely model binary schemas by combining simple "building +blocks" (e.g. @'Binrep.Type.NullTerminated.NullTerminated' a@) in regular +Haskell types. You can then receive high-performance serializers and parsers for +free via generics. + +binrep is /not/ a general-purpose parsing/serializing library. For that, see + + * mason, for fast and flexible serializing + * flatparse, for extremely performant parsing + * bytezap, for overly-fast serializing and parsing (but very limited) +-} + module Binrep - ( module Binrep.BLen + ( + -- * Class and instance design + -- $class-and-instance-design + + -- * Struct parsing & serializing + -- $struct-handlers + module Binrep.BLen , module Binrep.CBLen , module Binrep.Put , module Binrep.Put.Struct @@ -14,9 +34,46 @@ import Binrep.Get import Binrep.Get.Struct -{- TODO - * binrep is its own ecosystem where explicitness and correctness wins over - all. There are no binrep instances for 'Data.Void.Void' or 'GHC.Generics.V1' - because these can't be binrepped; rather than providing an absurd, possibly +{- $class-and-instance-design +At the core of binrep are a set of classes defining parsers, serializers, and +serialized length checkers on supported types. binrep is its own ecosystem where +explicitness and correctness win over all: + + * there are no binrep instances for 'Data.Void.Void' or 'GHC.Generics.V1' + because we can't use them; rather than providing an absurd, possibly convenient instance, we emit a type error for their attempted use. + * you can't put/get 'Data.Word.Word32's etc by themselves; you must provide + endianness information via the 'Binrep.Util.ByteOrder.ByteOrdered' newtype + * @'Get' 'Data.ByteString.ByteString'@ just consumes the whole input. seem + weird? it works with the combinators (it's actually rather important) + +Here are some important design decisions: + + * Fields in product types are concatenated left-to-right. e.g. @'Put' (l, r)@ + first puts @l@, then @r@. Nothing is placed between them. + * Sum types must define how to handle the constructor sum. + Generics are split into sum handlers and non-sum handlers. + binrep instances are not provided for types such as @'Either' a b@, where we + can't state how to choose between the 'Left' and 'Right' constructors. + * @'Refined.Refined' (pl `Refined.And` pr) a@ is re-associated to + @'Refined.Refined' pr ('Refined.Refined' pl a)@. The single layer of + refinements is ergonomic, but the way binrep instances work means we need + the latter. So 'Refined.And' instances essentially rewrite themselves to + work as if it were a stack of refinements. (See + 'Binrep.Type.Derived.NullTermPadded' for an example.) +-} + +{- $struct-handlers + +There are experimental "struct" handlers, which only work on data types that +look like C structs. That is, + + * every field must be constant length, and + * no sums allowed. + +The underlying runners for these are even faster-- they shouldn't do much more +work than the code a C compiler would generate for a similar @struct@. But they +are very inflexible (few binrep instances, hard to write by hand) and poorly +tested. Please be warned when using them. (And do consider sending bug reports +to the author!) -} diff --git a/src/Binrep/CBLen.hs b/src/Binrep/CBLen.hs --- a/src/Binrep/CBLen.hs +++ b/src/Binrep/CBLen.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} -- for nested type families +{-# LANGUAGE UndecidableInstances #-} -- due to various type algebra {-# LANGUAGE AllowAmbiguousTypes #-} -- for reification util module Binrep.CBLen where @@ -15,12 +15,34 @@ import Refined +import Binrep.Common.Class.TypeErrors ( ENoEmpty ) + +import GHC.Generics +import GHC.TypeError +import Data.Kind ( type Type ) + +import Data.Type.Equality +import Data.Type.Bool + +import Bytezap.Common.Generic ( type GTFoldMapCAddition ) + +import Binrep.Common.Via.Generically.NonSum + class IsCBLen a where type CBLen a :: Natural -instance IsCBLen () where type CBLen () = 0 +-- | Deriving via this instance necessitates @UndecidableInstances@. +instance Generic a => IsCBLen (GenericallyNonSum a) where + type CBLen (GenericallyNonSum a) = CBLenGenericNonSum a + +instance IsCBLen (Refined pr (Refined pl a)) + => IsCBLen (Refined (pl `And` pr) a) where + type CBLen (Refined (pl `And` pr) a) = CBLen (Refined pr (Refined pl a)) + instance (IsCBLen l, IsCBLen r) => IsCBLen (l, r) where type CBLen (l, r) = CBLen l + CBLen r +instance IsCBLen () where type CBLen () = 0 + instance IsCBLen Word8 where type CBLen Word8 = 2^0 instance IsCBLen Int8 where type CBLen Int8 = 2^0 instance IsCBLen Word16 where type CBLen Word16 = 2^1 @@ -33,9 +55,6 @@ instance IsCBLen a => IsCBLen (ByteOrdered end a) where type CBLen (ByteOrdered end a) = CBLen a -instance IsCBLen (Refined (pl `And` pr) a) where - type CBLen (Refined (pl `And` pr) a) = CBLen (Refined pr (Refined pl a)) - -- | Reify a type's constant byte length to the term level. cblen :: forall a. KnownNat (CBLen a) => Int cblen = natValInt @(CBLen a) @@ -55,3 +74,64 @@ type CBLenSym :: a ~> Natural data CBLenSym a type instance App CBLenSym a = CBLen a + +{- $generic-cblen + +Generically derive 'CBLen' type family instances. + +A type having a valid 'CBLen' instance usually indicates one of the following: + + * it's a primitive, or extremely simple + * it holds size information in its type + * it's constructed from other constant byte length types + +The first two cases must be handled manually. The third case is where Haskell +generics excel, and the one this module targets. + +You may derive a 'CBLen' type generically for a non-sum type with + + instance IsCBLen a where type CBLen a = CBLenGenericNonSum a + +You may attempt to derive a 'CBLen' type generically for a sum type with + + instance IsCBLen a where type CBLen a = CBLenGenericSum w a + +As with other generic sum type handlers, you must provide the type used to store +the sum tag for sum types. That sum tag type must have a 'CBLen', and every +constructor must have the same 'CBLen' for a 'CBLen' to be calculated. Not many types will fit those criteria, and the code is not well-tested. +-} + +-- | Using this necessitates @UndecidableInstances@. +type CBLenGenericSum (w :: Type) a = GCBLen w (Rep a) + +-- | Using this necessitates @UndecidableInstances@. +type CBLenGenericNonSum a = GTFoldMapCAddition CBLenSym (Rep a) + +type family GCBLen w (gf :: k -> Type) :: Natural where + GCBLen w (D1 _ gf) = GCBLen w gf + GCBLen _ V1 = TypeError ENoEmpty + GCBLen w (l :+: r) = CBLen w + GCBLenCaseMaybe (GCBLenSum (l :+: r)) + GCBLen w (C1 _ gf) = GTFoldMapCAddition CBLenSym gf + +--type family GCBLenSum (gf :: k -> Type) :: Maybe Natural where +type family GCBLenSum (gf :: k -> Type) where + GCBLenSum (C1 ('MetaCons name _ _) gf) = + JustX (GTFoldMapCAddition CBLenSym gf) name + GCBLenSum (l :+: r) = MaybeEq (GCBLenSum l) (GCBLenSum r) + +type family MaybeEq a b where + MaybeEq (JustX n nName) (JustX m _) = If (n == m) (JustX n nName) NothingX + MaybeEq _ _ = NothingX + +-- | I don't know how to pattern match in types without writing type families. +type family GCBLenCaseMaybe a where + GCBLenCaseMaybe (JustX n _) = n + GCBLenCaseMaybe NothingX = + TypeError + ( 'Text "Two constructors didn't have equal constant size." + ':$$: 'Text "Sry dunno how to thread errors thru LOL" + ) + +-- TODO rewrite this stuff to thread error info through! +data JustX a b +data NothingX diff --git a/src/Binrep/CBLen/Generic.hs b/src/Binrep/CBLen/Generic.hs deleted file mode 100644 --- a/src/Binrep/CBLen/Generic.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- due to type algebra - -{- | Generically derive 'CBLen' type family instances. - -A type having a valid 'CBLen' instance usually indicates one of the following: - - * it's a primitive, or extremely simple - * it holds size information in its type - * it's constructed from other constant byte length types - -The first two cases must be handled manually. The third case is where Haskell -generics excel, and the one this module targets. - -You can (attempt to) derive a 'CBLen' type family instance generically for a -type via - - 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. - -Then try using it. Hopefully it works, or you get a useful type error. If not, -sorry. I don't have much faith in this code. - --} - -module Binrep.CBLen.Generic where - -import Binrep.CBLen -import Binrep.Common.Class.TypeErrors ( ENoEmpty ) - -import GHC.Generics -import GHC.TypeLits -import Data.Kind - -import Data.Type.Equality -import Data.Type.Bool - -import Generic.Type.Assert.Error - -type CBLenGeneric (w :: Type) a = GCBLen w (Rep a) -type CBLenGenericNonSum a = CBLenGeneric (GAssertErrorSum a) a - -type family GCBLen w (f :: k -> Type) :: Natural where - GCBLen _ U1 = 0 - GCBLen _ (K1 i c) = CBLen c - GCBLen w (l :*: r) = GCBLen w l + GCBLen w r - - GCBLen w (l :+: r) = CBLen w + GCBLenCaseMaybe (GCBLenSum w (l :+: r)) - - GCBLen _ V1 = TypeError ENoEmpty - GCBLen w (M1 _ _ f) = GCBLen w f - ---type family GCBLenSum w (f :: k -> Type) :: Maybe Natural where -type family GCBLenSum w (f :: k -> Type) where - GCBLenSum w (C1 ('MetaCons name _ _) f) = JustX (GCBLen w f) name - GCBLenSum w (l :+: r) = MaybeEq (GCBLenSum w l) (GCBLenSum w r) - -type family MaybeEq a b where - MaybeEq (JustX n nName) (JustX m _) = If (n == m) (JustX n nName) NothingX - MaybeEq _ _ = NothingX - --- | I don't know how to pattern match in types without writing type families. -type family GCBLenCaseMaybe a where - GCBLenCaseMaybe (JustX n _) = n - GCBLenCaseMaybe NothingX = - TypeError - ( 'Text "Two constructors didn't have equal constant size." - ':$$: 'Text "Sry dunno how to thread errors thru LOL" - ) - --- TODO rewrite this stuff to thread error info through! -data JustX a b -data NothingX - diff --git a/src/Binrep/Common/Via/Generically/NonSum.hs b/src/Binrep/Common/Via/Generically/NonSum.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Via/Generically/NonSum.hs @@ -0,0 +1,3 @@ +module Binrep.Common.Via.Generically.NonSum where + +newtype GenericallyNonSum a = GenericallyNonSum { unGenericallyNonSum :: a } diff --git a/src/Binrep/Get.hs b/src/Binrep/Get.hs --- a/src/Binrep/Get.hs +++ b/src/Binrep/Get.hs @@ -7,7 +7,6 @@ ) where import Binrep.Get.Error -import Data.Functor.Identity import Binrep.Util.ByteOrder import Binrep.Common.Via.Prim ( ViaPrim(..) ) import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf ) @@ -26,10 +25,6 @@ import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty ) import GHC.TypeLits ( TypeError ) -import Data.Void -import Data.Word -import Data.Int - import GHC.Generics import Generic.Data.Function.Traverse import Generic.Type.Assert @@ -39,6 +34,12 @@ import Refined import Refined.Unsafe +import Data.Word +import Data.Int +import Data.Void +import Data.Functor.Identity +import Binrep.Common.Via.Generically.NonSum + type Getter a = FP.Parser E a class Get a where @@ -73,6 +74,12 @@ , GAssertNotVoid a, GAssertNotSum a ) => Getter a getGenericNonSum = genericTraverseNonSum @Get + +instance + ( Generic a, GTraverseNonSum Get (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => Get (GenericallyNonSum a) where + get = GenericallyNonSum <$> getGenericNonSum getGenericSum :: forall pt a diff --git a/src/Binrep/Get/Struct.hs b/src/Binrep/Get/Struct.hs --- a/src/Binrep/Get/Struct.hs +++ b/src/Binrep/Get/Struct.hs @@ -25,6 +25,11 @@ import Generic.Type.Assert +import Binrep.Common.Via.Generically.NonSum + +import Refined +import Refined.Unsafe + type GetterC = Parser E -- | constant size parser @@ -75,6 +80,16 @@ , GAssertNotVoid a, GAssertNotSum a ) => GetC (Generically a) where getC = Generically <$> getGenericStruct + +instance + ( Generic a, GParse GetC (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => GetC (GenericallyNonSum a) where + getC = GenericallyNonSum <$> getGenericStruct + +instance GetC (Refined pr (Refined pl a)) + => GetC (Refined (pl `And` pr) a) where + getC = (reallyUnsafeRefine . unrefine @pl . unrefine @pr) <$> getC instance GetC () where {-# INLINE getC #-} diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs --- a/src/Binrep/Put.hs +++ b/src/Binrep/Put.hs @@ -4,7 +4,6 @@ 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 @@ -16,10 +15,6 @@ 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.Type.Assert @@ -31,6 +26,12 @@ import Refined import Refined.Unsafe +import Data.Word +import Data.Int +import Data.Void +import Data.Functor.Identity +import Binrep.Common.Via.Generically.NonSum + type Putter = Poke RealWorld class Put a where put :: a -> Putter @@ -51,6 +52,12 @@ ) => a -> Putter putGenericNonSum = genericFoldMapNonSum @Put +instance + ( Generic a, GFoldMapNonSum Put (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => Put (GenericallyNonSum a) where + put = putGenericNonSum . unGenericallyNonSum + -- | Serialize a term of the sum type @a@ via its 'Generic' instance. -- -- You must provide a serializer for @a@'s constructors. This is regrettably @@ -62,9 +69,6 @@ , GAssertNotVoid a, GAssertSum a ) => (String -> Putter) -> a -> Putter putGenericSum = genericFoldMapSum @Put - --- We can't provide a Generically instance because the user must choose between --- sum and non-sum handlers. newtype ViaPutC a = ViaPutC { unViaPutC :: a } instance (PutC a, KnownNat (CBLen a)) => Put (ViaPutC a) where diff --git a/src/Binrep/Put/Struct.hs b/src/Binrep/Put/Struct.hs --- a/src/Binrep/Put/Struct.hs +++ b/src/Binrep/Put/Struct.hs @@ -24,6 +24,11 @@ import Generic.Type.Assert +import Binrep.Common.Via.Generically.NonSum + +import Refined +import Refined.Unsafe + type PutterC = Struct.Poke RealWorld -- | constant size putter @@ -51,6 +56,17 @@ , GAssertNotVoid a, GAssertNotSum a ) => PutC (Generically a) where putC (Generically a) = putGenericStruct a + +instance + ( Generic a, Struct.GPoke PutC (Rep a) + , GAssertNotVoid a, GAssertNotSum a + ) => PutC (GenericallyNonSum a) where + putC = putGenericStruct . unGenericallyNonSum + +instance PutC (Refined pr (Refined pl a)) + => PutC (Refined (pl `And` pr) a) where + putC = + putC . reallyUnsafeRefine @_ @pr . reallyUnsafeRefine @_ @pl . unrefine instance Prim' a => PutC (ViaPrim a) where putC = Struct.prim . unViaPrim diff --git a/src/Binrep/Test.hs b/src/Binrep/Test.hs --- a/src/Binrep/Test.hs +++ b/src/Binrep/Test.hs @@ -1,33 +1,26 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- for CBLen instances module Binrep.Test where import Binrep import Binrep.Type.Magic -import Binrep.CBLen.Generic import GHC.Generics ( Generic ) import Data.Word import Binrep.Util.ByteOrder +import Binrep.Common.Via.Generically.NonSum + data DMagic = DMagic { dMagic1_8b :: Magic '[0xFF, 0, 1, 0, 1, 0, 1, 0xFF] } deriving stock Generic - -instance IsCBLen DMagic where type CBLen DMagic = CBLenGenericNonSum DMagic -instance PutC DMagic where putC = putGenericStruct + deriving (IsCBLen, PutC) via GenericallyNonSum DMagic data DMagicSum = DMagicSum1 (Magic '[0]) | DMagicSum2 (Magic '[0xFF]) deriving stock Generic -instance IsCBLen DMagicSum where - type CBLen DMagicSum = CBLenGenericNonSum DMagicSum - data DStruct = DStruct { dStruct1 :: Magic '[0xFF, 0, 1, 0xFF] , dStruct2 :: ByteOrdered LE Word32 , dStruct3 :: () } deriving stock (Generic, Show) - -instance IsCBLen DStruct where type CBLen DStruct = CBLenGenericNonSum DStruct -instance GetC DStruct where getC = getGenericStruct -deriving via ViaGetC DStruct instance Get DStruct + deriving (IsCBLen, PutC, GetC) via GenericallyNonSum DStruct diff --git a/src/Binrep/Type/Derived/NullTermPadded.hs b/src/Binrep/Type/Derived/NullTermPadded.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Derived/NullTermPadded.hs @@ -0,0 +1,21 @@ +{- | Null-terminated, then null-padded data. + +This is defined using the composition of existing 'NullTerminate' and +'NullPad' predicates, plus the re-associating binrep instances for the 'And' +predicate combinator. It kind of just magically works. +-} + +module Binrep.Type.Derived.NullTermPadded where + +import Binrep.Type.NullTerminated +import Binrep.Type.NullPadded + +import Refined + +-- | Predicate for null-terminated, then null-padded data. +type NullTermPad n = NullTerminate `And` NullPad n + +-- | Null-terminated data, which is then null-padded to the given length. +-- +-- Instantiate with @ByteString@ for a null-padded C string. +type NullTermPadded n = Refined (NullTermPad n) 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 @@ -5,34 +5,29 @@ There are two main flavors of magics: - * "random" bytes e.g. Zstandard: @28 B5 2F FD@ - * printable ASCII bytes e.g. Ogg: @4F 67 67 53@ -> OggS - -For bytewise magics, use type-level 'Natural' lists. -For ASCII magics, use 'Symbol's (type-level strings). - -Previously, I squashed these into a representationally-safe type. Now the check -only occurs during reification. So you are able to define invalid magics now -(bytes over 255, non-ASCII characters), and potentially use them, but you'll get -a clear type error like "no instance for ByteVal 256" when attempting to reify. + * byte magics e.g. Zstandard: @28 B5 2F FD@ + * printable magics e.g. Ogg: @4F 67 67 53@ -> @OggS@ (in ASCII) -String magics are restricted to ASCII, and will type error during reification -otherwise. If you really want UTF-8, please read 'Binrep.Type.Magic.UTF8'. +For byte magics, use type-level 'Natural' lists. +For printable magics, use 'Symbol's (type-level strings). -} -module Binrep.Type.Magic where +module Binrep.Type.Magic + ( Magic(Magic) + , Magical(type MagicBytes) + , type Length + ) where -import Binrep -import FlatParse.Basic qualified as FP -import Util.TypeNats ( natValInt ) +import Data.Type.Symbol.Utf8 ( type SymbolToUtf8 ) -import GHC.TypeLits +import Util.TypeNats ( natValInt ) +import GHC.TypeLits ( type Natural, type Symbol, type KnownNat, type (+) ) import GHC.Generics ( Generic ) import Data.Data ( Data ) - import Strongweak +import Binrep import Bytezap.Struct.TypeLits.Bytes ( ReifyBytesW64(reifyBytesW64) ) import Bytezap.Parser.Struct.TypeLits.Bytes ( ParseReifyBytesW64(parseReifyBytesW64) ) @@ -40,6 +35,7 @@ import Data.ByteString.Internal qualified as B import GHC.Exts ( Int(I#), plusAddr#, Ptr(Ptr) ) import Foreign.Marshal.Utils ( copyBytes ) +import FlatParse.Basic qualified as FP -- | A singleton data type representing a "magic number" via a phantom type. -- @@ -98,43 +94,6 @@ , ReifyBytesW64 bs, KnownNat (Length bs) ) => Get (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 - -{- -I do lots of functions on lists, because they're structurally simple. But you -can't pass type-level functions as arguments between type families. singletons -solves a related (?) problem using defunctionalization, where you manually write -out the function applications or something. Essentially, you can't do this: - - type family Map (f :: x -> y) (a :: [x]) :: [y] where - Map _ '[] = '[] - Map f (a ': as) = f a ': Map f as - -So you have to write that out for every concrete function over lists. - -TODO wellll we depend on defun-core now so may as well use that LOL --} - -type family SymbolUnicodeCodepoints (a :: Symbol) :: [Natural] where - SymbolUnicodeCodepoints a = CharListUnicodeCodepoints (SymbolAsCharList a) - -type family CharListUnicodeCodepoints (a :: [Char]) :: [Natural] where - CharListUnicodeCodepoints '[] = '[] - CharListUnicodeCodepoints (c ': cs) = CharToNat c ': CharListUnicodeCodepoints cs - -type family SymbolAsCharList (a :: Symbol) :: [Char] where - SymbolAsCharList a = SymbolAsCharList' (UnconsSymbol a) - -type family SymbolAsCharList' (a :: Maybe (Char, Symbol)) :: [Char] where - SymbolAsCharList' 'Nothing = '[] - SymbolAsCharList' ('Just '(c, s)) = c ': SymbolAsCharList' (UnconsSymbol s) - --------------------------------------------------------------------------------- - -- | Types which define a magic value. class Magical (a :: k) where -- | How to turn the type into a list of bytes. @@ -143,8 +102,10 @@ -- | Type-level naturals go as-is. (Make sure you don't go over 255, though!) 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, --- which will fail further down. -instance Magical (sym :: Symbol) where - type MagicBytes sym = SymbolUnicodeCodepoints sym +-- | Type-level symbols are converted to UTF-8. +instance Magical (sym :: Symbol) where type MagicBytes sym = SymbolToUtf8 sym + +-- | 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/src/Binrep/Type/NullPadded.hs b/src/Binrep/Type/NullPadded.hs --- a/src/Binrep/Type/NullPadded.hs +++ b/src/Binrep/Type/NullPadded.hs @@ -1,19 +1,5 @@ -- | Data null-padded to a given length. -{- TODO -Null padding using the underlying type's instances doesn't necessarily work. -'ByteString's must parse until the end of the string. -Or maybe that's correct, and we must use null terminated bytestrings with null -padding...? Huh. - -...well, doing that fixes my issue. And thinking about it, I imagine that's how -C does it (you're still going to be wanting to deal with cstrings regardless of -null padding). Cool!! - -OK, all good. But because of that, I should provide a convenience wrapper to put -nullpad+nullterm together. --} - {-# LANGUAGE OverloadedStrings #-} module Binrep.Type.NullPadded where @@ -72,8 +58,8 @@ n = natValInt @n len = blen a -instance (BLen a, KnownNat n, PutC a) => PutC (NullPadded n a) where - putC ra = BZ.Struct.sequencePokes (putC a) len +instance (BLen a, KnownNat n, Put a) => PutC (NullPadded n a) where + putC ra = BZ.Struct.sequencePokes (BZ.toStructPoke (put a)) len (BZ.Struct.replicateByte paddingLen 0x00) where a = unrefine ra diff --git a/src/Util/TypeNats.hs b/src/Util/TypeNats.hs --- a/src/Util/TypeNats.hs +++ b/src/Util/TypeNats.hs @@ -1,12 +1,11 @@ {-# 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', type (+) ) +import GHC.TypeNats ( Natural, KnownNat, natVal' ) import GHC.Exts ( proxy#, Proxy# ) natVal'' :: forall n. KnownNat n => Natural @@ -16,9 +15,3 @@ natValInt :: forall n. KnownNat n => Int 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