binrep 0.6.0 → 0.7.0

raw patch · 14 files changed

+486/−190 lines, 14 filesdep +defun-coredep +generic-type-assertsdep −generic-data-assertsdep ~generic-data-functionsPVP ok

version bump matches the API change (PVP)

Dependencies added: defun-core, generic-type-asserts

Dependencies removed: generic-data-asserts

Dependency ranges changed: generic-data-functions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• binrep.cabal +12/−7
• src/Binrep.hs +2/−0
• src/Binrep/BLen.hs +13/−4
• src/Binrep/CBLen.hs +15/−0
• src/Binrep/CBLen/Generic.hs +6/−4
• src/Binrep/Get.hs +80/−129
• src/Binrep/Get/Error.hs +92/−0
• src/Binrep/Get/Struct.hs +126/−0
• src/Binrep/Put.hs +15/−4
• src/Binrep/Put/Struct.hs +12/−4
• src/Binrep/Test.hs +19/−1
• src/Binrep/Type/Magic.hs +37/−16
• src/Binrep/Type/NullPadded.hs +46/−21

@@ -1,3 +1,14 @@+## 0.7.0 (2024-04-10)+* provide "C struct" parser (from bytezap)+* fill out some missing C struct instances+* speed up magic parsing (sped up serializing in v0.6.0)+* add special binrep instances for `And` predicate combinator which re-associate+  to wrap the left predicate in the right+  * this gives a clean solution to the null-padded null-terminated bytestring,+    and appears to be generally sound! felt great to discover+* add Generically instances for C struct parser/serializers+  * can't for regular parser/serializer because of sum/non-sum choice+ ## 0.6.0 (2024-04-05) * many updates to parsing/serializing internals, including generics * provide "C struct" serializer

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           binrep-version:        0.6.0+version:        0.7.0 synopsis:       Encode precise binary representations directly in types description:    Please see README.md. category:       Data, Serialization, Generics@@ -41,6 +41,8 @@       Binrep.Common.Via.Prim       Binrep.Generic       Binrep.Get+      Binrep.Get.Error+      Binrep.Get.Struct       Binrep.Put       Binrep.Put.Struct       Binrep.Test@@ -86,9 +88,10 @@     , bytestring >=0.11 && <0.13     , bytezap >=1.1.0 && <1.2     , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*     , flatparse >=0.5.0.2 && <0.6-    , generic-data-asserts >=0.1.0 && <0.2-    , generic-data-functions >=0.4.1 && <0.5+    , generic-data-functions >=0.5.0 && <0.6+    , generic-type-asserts >=0.3.0 && <0.4     , parser-combinators >=1.3.0 && <1.4     , refined1 ==0.9.*     , strongweak >=0.6.0 && <0.7@@ -129,10 +132,11 @@     , bytestring >=0.11 && <0.13     , bytezap >=1.1.0 && <1.2     , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*     , flatparse >=0.5.0.2 && <0.6-    , generic-data-asserts >=0.1.0 && <0.2-    , generic-data-functions >=0.4.1 && <0.5+    , generic-data-functions >=0.5.0 && <0.6     , generic-random >=1.5.0.1 && <1.6+    , generic-type-asserts >=0.3.0 && <0.4     , hspec >=2.7 && <2.12     , parser-combinators >=1.3.0 && <1.4     , quickcheck-instances >=0.3.26 && <0.4@@ -170,10 +174,11 @@     , bytestring >=0.11 && <0.13     , bytezap >=1.1.0 && <1.2     , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*     , flatparse >=0.5.0.2 && <0.6     , gauge-    , generic-data-asserts >=0.1.0 && <0.2-    , generic-data-functions >=0.4.1 && <0.5+    , generic-data-functions >=0.5.0 && <0.6+    , generic-type-asserts >=0.3.0 && <0.4     , parser-combinators >=1.3.0 && <1.4     , refined1 ==0.9.*     , strongweak >=0.6.0 && <0.7

@@ -4,6 +4,7 @@   , module Binrep.Put   , module Binrep.Put.Struct   , module Binrep.Get+  , module Binrep.Get.Struct   ) where  import Binrep.BLen@@ -11,6 +12,7 @@ import Binrep.Put import Binrep.Put.Struct import Binrep.Get+import Binrep.Get.Struct  {- TODO   * binrep is its own ecosystem where explicitness and correctness wins over

@@ -37,9 +37,11 @@ import Data.Monoid qualified as Monoid import GHC.Generics import Generic.Data.Function.FoldMap-import Generic.Data.Rep.Assert-import Generic.Data.Function.Common+import Generic.Type.Assert +import Refined+import Refined.Unsafe+ -- | Class for types with easily-calculated length in bytes. -- -- If it appears hard to calculate byte length for a given type (e.g. without@@ -71,11 +73,18 @@ -- Alas. Do write your own instance if you want better performance! blenGenericSum     :: forall a-    .  ( Generic a, GFoldMapSum BLen 'SumOnly (Rep a)+    .  ( Generic a, GFoldMapSum BLen (Rep a)        , GAssertNotVoid a, GAssertSum a     ) => (String -> Int) -> a -> Int blenGenericSum f =-    Monoid.getSum . genericFoldMapSum @BLen @'SumOnly (Monoid.Sum <$> f)+    Monoid.getSum . genericFoldMapSum @BLen (Monoid.Sum <$> f)++-- We can't provide a Generically instance because the user must choose between+-- sum and non-sum handlers.++instance BLen (Refined pr (Refined pl a))+  => BLen (Refined (pl `And` pr) a) where+    blen = blen . reallyUnsafeRefine @_ @pr . reallyUnsafeRefine @_ @pl . unrefine  instance TypeError ENoEmpty => BLen Void where blen = undefined instance TypeError ENoSum => BLen (Either a b) where blen = undefined

@@ -11,6 +11,10 @@ import GHC.Exts ( Int#, Int(I#), Proxy# ) import Util.TypeNats ( natValInt ) +import DeFun.Core ( type (~>), type App )++import Refined+ class IsCBLen a where type CBLen a :: Natural  instance IsCBLen () where type CBLen () = 0@@ -29,6 +33,9 @@ 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)@@ -40,3 +47,11 @@ cblenProxy# :: forall a. KnownNat (CBLen a) => Proxy# a -> Int# cblenProxy# _ = i#   where !(I# i#) = natValInt @(CBLen a)++-- | Defunctionalization symbol for 'CBLen'.+--+-- This is required for parameterized type-level generics e.g. bytezap's+-- 'Bytezap.Struct.Generic.GPokeBase'.+type CBLenSym :: a ~> Natural+data CBLenSym a+type instance App CBLenSym a = CBLen a

@@ -1,6 +1,6 @@-{-# LANGUAGE UndecidableInstances #-} -- hugely unsafe module+{-# LANGUAGE UndecidableInstances #-} -- due to type algebra -{- | _Experimental._ Generically derive 'CBLen' type family instances.+{- | Generically derive 'CBLen' type family instances.  A type having a valid 'CBLen' instance usually indicates one of the following: @@ -21,6 +21,7 @@  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@@ -35,9 +36,10 @@ import Data.Type.Equality import Data.Type.Bool --- TODO provide non-sum version+import Generic.Type.Assert.Error -type CBLenGeneric w a = GCBLen w (Rep a)+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

@@ -2,21 +2,22 @@ {-# LANGUAGE BlockArguments #-}  module Binrep.Get-  ( Getter, Get(..), runGet, runGetter-  , E(..), EBase(..), EGeneric(..), EGenericSum(..)-  , eBase-  , getEBase-  -- , GetWith(..), runGetWith-  , getPrim-  , getGenericNonSum, getGenericSum+  ( module Binrep.Get+  , module Binrep.Get.Error   ) 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 ) import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap ) +import Binrep.Get.Struct ( GetC(getC) )+import Bytezap.Parser.Struct qualified as BZ+import Binrep.CBLen ( IsCBLen(CBLen), cblen )+import GHC.TypeLits ( KnownNat )+ import FlatParse.Basic qualified as FP import Raehik.Compat.FlatParse.Basic.Prim qualified as FP @@ -29,128 +30,16 @@ 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)+import Generic.Type.Assert -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+import GHC.Exts ( minusAddr#, Int(I#), Int#, plusAddr#, (+#) ) --- | Parse. On parse error, coat it in a generic context layer.-getWrapGeneric :: Get a => String -> (E -> EGeneric E) -> Getter a-getWrapGeneric = getWrapGeneric' get+import Refined+import Refined.Unsafe -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+type Getter a = FP.Parser E a  class Get a where     -- | Parse from binary.@@ -180,19 +69,78 @@  getGenericNonSum     :: forall a-    .  (Generic a, GTraverseNonSum Get (Rep 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)+    .  ( Generic a, GTraverseSum Get (Rep a)        , Get pt        , GAssertNotVoid a, GAssertSum a     ) => PfxTagCfg pt -> Getter a-getGenericSum = genericTraverseSum @Get @'SumOnly+getGenericSum = genericTraverseSum @Get +-- We can't provide a Generically instance because the user must choose between+-- sum and non-sum handlers.++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++-- | Convert a bytezap struct parser to a flatparse parser.+bzToFp+    :: forall a e st. KnownNat (CBLen a)+    => BZ.ParserT st e a -> FP.ParserT st e a+bzToFp (BZ.ParserT p) = FP.ensure (I# len#) >> (FP.ParserT $ \fpc _eob s st0 ->+    case p fpc s 0# st0 of+      BZ.OK#   st1 a -> FP.OK#   st1 a (s `plusAddr#` len#)+      BZ.Fail# st1   -> FP.Fail# st1+      BZ.Err#  st1 e -> FP.Err#  st1 e+    )+  where+    !(I# len#) = cblen @a++fpToBz+    :: FP.ParserT st e a -> Int#+    -> (a -> Int# -> BZ.ParserT st e r) -> BZ.ParserT st e r+fpToBz (FP.ParserT p) len# fp = BZ.ParserT $ \fpc base# os# st0 ->+    case p fpc (base# `plusAddr#` (os# +# len#)) (base# `plusAddr#` os#) st0 of+      FP.OK#   st1 a s ->+        let unconsumed# = s `minusAddr#` (base# `plusAddr#` os#)+        in  BZ.runParserT# (fp a unconsumed#) fpc base# (os# +# unconsumed#) st1+      FP.Fail# st1     -> BZ.Fail# st1+      FP.Err#  st1 e   -> BZ.Err#  st1 e++-- | 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++newtype ViaGetC a = ViaGetC { unViaGetC :: a }+instance (GetC a, KnownNat (CBLen a)) => Get (ViaGetC a) where+    {-# INLINE get #-}+    get = ViaGetC <$> bzToFp getC+ instance TypeError ENoEmpty => Get Void where get = undefined instance TypeError ENoSum => Get (Either a b) where get = undefined @@ -255,10 +203,10 @@ 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)+deriving via 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)+deriving via  Int8 instance Get (ByteOrdered end  Int8)  -- | Parse any 'Prim''. getPrim :: forall a. Prim' a => Getter a@@ -272,6 +220,9 @@     instance (Prim' a, ByteSwap a) => Get (ByteOrdered 'LittleEndian a) deriving via ViaPrim (ByteOrdered    'BigEndian a)     instance (Prim' a, ByteSwap a) => Get (ByteOrdered    'BigEndian a)++instance Get (Refined pr (Refined pl a)) => Get (Refined (pl `And` pr) a) where+    get = (reallyUnsafeRefine . unrefine @pl . unrefine @pr) <$> get  {- 

@@ -0,0 +1,92 @@+-- | Error data type definitions (shared between parsers).++module Binrep.Get.Error where++import GHC.Generics ( Generic )+import Data.Text ( Text )+import Numeric.Natural ( Natural )+import Data.Word ( Word8 )+import Data.ByteString ( ByteString )++-- | 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 ByteString ByteString+  -- ^ expected first, got second++  | EFailNamed String+  -- ^ known fail++  | EFailParse String 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)

@@ -0,0 +1,126 @@+{-# LANGUAGE UndecidableInstances #-} -- for Generically instance++module Binrep.Get.Struct where++import Binrep.Get.Error+import Bytezap.Parser.Struct+import Bytezap.Parser.Struct.Generic+import Binrep.CBLen+import Foreign.Ptr ( Ptr )+import Data.Void ( Void )+import GHC.Exts ( Proxy#, Int(I#) )+import GHC.TypeNats ( KnownNat )+import GHC.Generics++import Binrep.Common.Via.Prim ( ViaPrim(..) )+import Raehik.Compat.Data.Primitive.Types ( Prim' )++import Data.Word ( Word8 )+import Data.Int ( Int8 )+import Binrep.Util.ByteOrder+import Data.Functor.Identity+import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )++import Data.ByteString qualified as B++import Generic.Type.Assert++type GetterC = Parser E++-- | constant size parser+class GetC a where getC :: GetterC a++runGetCBs+    :: forall a. (GetC a, KnownNat (CBLen a))+    => B.ByteString -> Either E a+runGetCBs bs =+    if   cblen @a <= B.length bs+    then unsafeRunGetC' unsafeRunParserBs bs+    else Left $ E 0 $ EBase $ ERanOut 0 -- TODO made up numbers++-- | doesn't check len+unsafeRunGetC'+    :: forall a buf. GetC a+    => (forall e. buf -> Parser e a -> Result e a)+    -> buf -> Either E a+unsafeRunGetC' p buf =+    case p buf getC of+      OK   a -> Right a+      Fail   -> Left EFail+      Err  e -> Left e++-- | doesn't check len+unsafeRunGetCPtr+    :: forall a. GetC a+    => Ptr Word8 -> Either E a+unsafeRunGetCPtr = unsafeRunGetC' unsafeRunParserPtr++instance GParseBase GetC where+    type GParseBaseSt GetC = Proxy# Void+    type GParseBaseC  GetC a = GetC a+    type GParseBaseE  GetC = E+    gParseBase = getC+    type GParseBaseLenTF GetC = CBLenSym++-- | Serialize a term of the struct-like type @a@ via its 'Generic' instance.+getGenericStruct+    :: forall a+    .  ( Generic a, GParse GetC (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => GetterC a+getGenericStruct = to <$> gParse @GetC++instance+  ( Generic a, GParse GetC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => GetC (Generically a) where+    getC = Generically <$> getGenericStruct++instance GetC () where+    {-# INLINE getC #-}+    getC = constParse ()++instance Prim' a => GetC (ViaPrim a) where+    getC = ViaPrim <$> prim+    {-# INLINE getC #-}++instance GetC a => GetC (Identity a) where getC = Identity <$> getC++deriving via ViaPrim Word8 instance GetC Word8+deriving via ViaPrim  Int8 instance GetC  Int8+deriving via Word8 instance GetC (ByteOrdered end Word8)+deriving via  Int8 instance GetC (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) => GetC (ByteOrdered 'LittleEndian a)+deriving via ViaPrim (ByteOrdered    'BigEndian a)+    instance (Prim' a, ByteSwap a) => GetC (ByteOrdered    'BigEndian a)++{-++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++-- | Look weird? Yeah. But it's correct :)+instance (PutC l, KnownNat (CBLen l), PutC r) => PutC (l, r) where+    {-# INLINE putC #-}+    putC (l, r) = sequencePokes (putC l) (cblen @l) (putC r)++-}++eCBase :: EBase -> GetterC a+eCBase eb = ParserT $ \_fpc _base os# st ->+    Err# st (E (I# os#) $ EBase eb)++getECBase :: GetterC a -> EBase -> GetterC a+getECBase (ParserT p) eb = ParserT $ \fpc base os# st0 ->+    case p fpc base os# st0 of+      Fail# st1   -> Err# st1 (E (I# os#) $ EBase eb)+      Err#  st1 e -> Err# st1 (E (I# os#) $ EAnd e eb)+      x -> x

@@ -22,19 +22,22 @@  import GHC.Generics import Generic.Data.Function.FoldMap-import Generic.Data.Function.Common-import Generic.Data.Rep.Assert+import Generic.Type.Assert  import Control.Monad.ST ( RealWorld )  import Binrep.Put.Struct ( PutC(putC) ) +import Refined+import Refined.Unsafe+ 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) +-- | Serialize generically using generic 'foldMap'. instance GenericFoldMap Put where     type GenericFoldMapM Put = Putter     type GenericFoldMapC Put a = Put a@@ -55,11 +58,14 @@ -- if you want better performance! putGenericSum     :: forall a-    .  ( Generic a, GFoldMapSum Put 'SumOnly (Rep a)+    .  ( Generic a, GFoldMapSum Put (Rep a)        , GAssertNotVoid a, GAssertSum a     ) => (String -> Putter) -> a -> Putter-putGenericSum = genericFoldMapSum @Put @'SumOnly+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     {-# INLINE put #-}@@ -115,3 +121,8 @@     instance (Prim' a, ByteSwap a) => Put (ByteOrdered 'LittleEndian a) deriving via ViaPrim (ByteOrdered    'BigEndian a)     instance (Prim' a, ByteSwap a) => Put (ByteOrdered    'BigEndian a)++-- | Put types refined with multiple predicates by wrapping the left+--   predicate with the right. LOL REALLY?+instance Put (Refined pr (Refined pl a)) => Put (Refined (pl `And` pr) a) where+    put = put . reallyUnsafeRefine @_ @pr . reallyUnsafeRefine @_ @pl . unrefine

@@ -22,6 +22,8 @@ import GHC.TypeLits ( TypeError ) import Data.Void +import Generic.Type.Assert+ type PutterC = Struct.Poke RealWorld  -- | constant size putter@@ -34,15 +36,21 @@     type GPokeBaseSt PutC   = RealWorld     type GPokeBaseC  PutC a = PutC a     gPokeBase = Struct.unPoke . putC-    type KnownSizeOf' PutC a = KnownNat (CBLen a)-    sizeOf' = cblenProxy#+    type GPokeBaseLenTF PutC = CBLenSym  -- | 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+    .  ( Generic a, Struct.GPoke PutC (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => a -> PutterC putGenericStruct = Struct.Poke . Struct.gPoke @PutC . from++instance+  ( Generic a, Struct.GPoke PutC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => PutC (Generically a) where+    putC (Generically a) = putGenericStruct a  instance Prim' a => PutC (ViaPrim a) where     putC = Struct.prim . unViaPrim

@@ -6,10 +6,28 @@ import Binrep.Type.Magic import Binrep.CBLen.Generic import GHC.Generics ( Generic )+import Data.Word+import Binrep.Util.ByteOrder  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 IsCBLen DMagic where type CBLen DMagic = CBLenGenericNonSum DMagic instance PutC DMagic where putC = putGenericStruct++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

@@ -23,9 +23,7 @@ module Binrep.Type.Magic where  import Binrep-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@@ -35,6 +33,14 @@  import Strongweak +import Bytezap.Struct.TypeLits.Bytes ( ReifyBytesW64(reifyBytesW64) )+import Bytezap.Parser.Struct.TypeLits.Bytes+  ( ParseReifyBytesW64(parseReifyBytesW64) )+import Bytezap.Parser.Struct qualified as BZ+import Data.ByteString.Internal qualified as B+import GHC.Exts ( Int(I#), plusAddr#, Ptr(Ptr) )+import Foreign.Marshal.Utils ( copyBytes )+ -- | A singleton data type representing a "magic number" via a phantom type. -- -- The phantom type variable unambiguously defines a constant bytestring.@@ -63,22 +69,35 @@ 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-    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 (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-        else eBase $ EExpected expected (B.copy actual)+{- this works, but is ugly.+* we have to duplicate our error wrapping because errors use parser internals+* we throw the magic into the error, so we need the serializer constraints too+I mean, it's fine. It's correct. It's as fast as possible. But it looks bad :<+-}+instance+  ( bs ~ MagicBytes a, ParseReifyBytesW64 bs+  , ReifyBytesW64 bs, KnownNat (Length bs)+  ) => GetC (Magic a) where+    getC = BZ.ParserT $ \fpc base os# st0 ->+        case BZ.runParserT# (parseReifyBytesW64 @bs) fpc base os# st0 of+          BZ.OK#   st1 () -> BZ.OK#  st1 Magic+          BZ.Fail# st1    ->+            let bsActual = B.unsafeCreate len (\buf -> copyBytes buf (Ptr (base `plusAddr#` os#)) len)+                eb = EExpected bsExpected bsActual+            in  BZ.Err# st1 (E (I# os#) $ EBase eb)+          BZ.Err#  st1 e  ->+            let bsActual = B.unsafeCreate len (\buf -> copyBytes buf (Ptr (base `plusAddr#` os#)) len)+                eb = EExpected bsExpected bsActual+            in  BZ.Err# st1 (E (I# os#) $ EAnd e eb)       where-        expected = runPut magic-        magic = Magic :: Magic a+        len = natValInt @(Length bs)+        bsExpected = runPutC (Magic :: Magic a) +deriving via ViaGetC (Magic a) instance+  ( bs ~ MagicBytes a, ParseReifyBytesW64 bs+  , 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@@ -96,6 +115,8 @@         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

@@ -1,5 +1,19 @@ -- | 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@@ -21,27 +35,33 @@  import Data.Typeable ( typeRep ) +import Bytezap.Parser.Struct qualified as BZG+import GHC.Exts ( Int(I#) )+ data NullPad (n :: Natural) --- | A type which is to be null-padded to a given total length.------ Given some @a :: 'NullPadded' n a@, it is guaranteed that------ @--- 'blen' a '<=' 'natValInt' \@n--- @------ thus------ @--- 'natValInt' \@n '-' 'blen' a '>=' 0--- @------ That is, the serialized stored data will not be longer than the total length.------ The binrep instances are careful not to construct bytestrings unnecessarily.+{- | A type which is to be null-padded to a given total length.++Given some @a :: 'NullPadded' n a@, it is guaranteed that++@+'blen' a '<=' 'natValInt' \@n+@++thus++@+'natValInt' \@n '-' 'blen' a '>=' 0+@++That is, the serialized stored data will not be longer than the total length.+-} type NullPadded n a = Refined (NullPad n) a +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)++-- | Assert that term will fit. instance (BLen a, KnownNat n) => Predicate (NullPad n) a where     validate p a       | len <= n = success@@ -52,15 +72,12 @@         n = natValInt @n         len = blen a -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+        len = blen a         paddingLen = natValInt @n - len         -- ^ refinement guarantees >=0 @@ -70,6 +87,14 @@         a = unrefine ra         paddingLen = natValInt @n - blen a         -- ^ refinement guarantees >=0++-- | Run a @Getter a@ isolated to @n@ bytes.+instance (KnownNat n, Get a) => GetC (NullPadded n a) where+    getC = fpToBz get len# $ \a _unconsumed# ->+        -- TODO consume nulls lol+        BZG.constParse $ reallyUnsafeRefine a+      where+        !(I# len#) = natValInt @n  instance (Get a, KnownNat n) => Get (NullPadded n a) where     get = do