binrep 0.2.0 → 0.3.0

raw patch · 33 files changed

+755/−268 lines, 33 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +6/−0
• binrep.cabal +23/−7
• src/Binrep.hs +14/−4
• src/Binrep/BLen.hs +71/−29
• src/Binrep/CBLen.hs +0/−21
• src/Binrep/Example.hs +21/−23
• src/Binrep/Example/Tar.hs +6/−12
• src/Binrep/Example/Tiff.hs +7/−11
• src/Binrep/Example/Wav.hs +6/−10
• src/Binrep/Generic.hs +33/−3
• src/Binrep/Generic/BLen.hs +1/−0
• src/Binrep/Generic/CBLen.hs +15/−17
• src/Binrep/Generic/Get.hs +61/−40
• src/Binrep/Generic/Internal.hs +4/−8
• src/Binrep/Generic/Put.hs +1/−0
• src/Binrep/Get.hs +84/−10
• src/Binrep/Put.hs +6/−0
• src/Binrep/Type/AsciiNat.hs +2/−4
• src/Binrep/Type/Byte.hs +14/−10
• src/Binrep/Type/ByteString.hs +2/−3
• src/Binrep/Type/Int.hs +14/−15
• src/Binrep/Type/Magic.hs +44/−22
• src/Binrep/Type/Magic/UTF8.hs +1/−1
• src/Binrep/Type/NullPadded.hs +6/−7
• src/Binrep/Type/Sized.hs +1/−3
• src/Binrep/Type/Text.hs +13/−4
• src/Binrep/Type/Varint.hs +136/−0
• src/Binrep/Type/Vector.hs +1/−2
• src/Haskpatch/Format/Bps.hs +46/−0
• src/Haskpatch/Format/Vcdiff.hs +57/−0
• src/Util/Generic.hs +29/−0
• test/Binrep/LawsSpec.hs +22/−2

@@ -1,3 +1,11 @@+## 0.3.0 (2022-08-27)+  * useful parsing errors in `Get`+    * e.g. if parsing fails at "any Word64", emits "ran out, needed 8 bytes"+    * generic deriver places tons of data type info in highly structured errors+  * move `CBLen` into `BLen` as an associated type family+  * clean up magics (another open type family to associated)+  * add initial varint definitions at `Binrep.Type.Varint`+ ## 0.2.0 (2022-07-07) Multiple rewrites (unable to push to Hackage for a while due to dependencies). 

@@ -20,6 +20,12 @@   * **Performant:** Parsing and serialization is low-level and *extremely fast*,     using [flatparse][gh-flatparse] and [mason][gh-mason] respectively. +## Usage+### Dependencies+You need the **ICU library**. For running, you just need the runtime. For+building, you need development files as well (headers etc). Alternatively, you+may turn off the ICU features with a Cabal flag.+ ## Philosophy ### Modelling, not serializing binrep is good at modelling binary data formats. It is not a plain

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           binrep-version:        0.2.0+version:        0.3.0 synopsis:       Encode precise binary representations directly in types description:    Please see README.md. category:       Data, Serialization@@ -17,7 +17,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC ==9.2.2+    GHC ==9.2.4 extra-source-files:     README.md     CHANGELOG.md@@ -26,12 +26,16 @@   type: git   location: https://github.com/raehik/binrep +flag icu+  description: use text-icu package (requires ICU library)+  manual: True+  default: True+ library   exposed-modules:       Binrep       Binrep.BLen       Binrep.BLen.Internal.AsBLen-      Binrep.CBLen       Binrep.Example       Binrep.Example.FileTable       Binrep.Example.Tar@@ -57,9 +61,13 @@       Binrep.Type.NullPadded       Binrep.Type.Sized       Binrep.Type.Text+      Binrep.Type.Varint       Binrep.Type.Vector       Binrep.Util       Data.Aeson.Extra.SizedVector+      Haskpatch.Format.Bps+      Haskpatch.Format.Vcdiff+      Util.Generic   other-modules:       Paths_binrep   hs-source-dirs:@@ -94,6 +102,7 @@       MagicHash       ImportQualifiedPost       StandaloneKindSignatures+      BinaryLiterals       ScopedTypeVariables       TypeOperators   ghc-options: -Wall@@ -107,10 +116,13 @@     , megaparsec >=9.2.0 && <9.3     , refined ==0.7.*     , strongweak >=0.3.1 && <0.4-    , text ==1.2.*-    , text-icu >=0.8.0.1 && <0.9+    , text >=1.2 && <2.1     , vector >=0.12.3.1 && <0.13     , vector-sized >=1.5.0 && <1.6+  if flag(icu)+    cpp-options: -DHAVE_ICU+    build-depends:+        text-icu >=0.8.0.1 && <0.9   default-language: Haskell2010  test-suite spec@@ -153,6 +165,7 @@       MagicHash       ImportQualifiedPost       StandaloneKindSignatures+      BinaryLiterals       ScopedTypeVariables       TypeOperators   ghc-options: -Wall@@ -173,8 +186,11 @@     , quickcheck-instances >=0.3.26 && <0.4     , refined ==0.7.*     , strongweak >=0.3.1 && <0.4-    , text ==1.2.*-    , text-icu >=0.8.0.1 && <0.9+    , text >=1.2 && <2.1     , vector >=0.12.3.1 && <0.13     , vector-sized >=1.5.0 && <1.6+  if flag(icu)+    cpp-options: -DHAVE_ICU+    build-depends:+        text-icu >=0.8.0.1 && <0.9   default-language: Haskell2010

@@ -1,16 +1,26 @@-{- | Helper module to bring most functionality into scope.+{- | Main end-user binrep module bundling most functionality. -Generics are in a separate module (to prevent module import cycles).+Generics are bundled together in 'Binrep.Generic'. -}  module Binrep   ( module Binrep.BLen-  , module Binrep.CBLen   , module Binrep.Put   , module Binrep.Get++  -- * Extras+  , blenViaPut   ) where  import Binrep.BLen-import Binrep.CBLen import Binrep.Put import Binrep.Get++-- | The length in bytes of a 'Put'-able type is the length of the serialized+--   term.+--+-- Do not use this in 'BLen' instances. It's intended as a proof, and+-- potentially for testing purposes. Calculating length in bytes shouldn't+-- involve serializing (it should be fast and use minimal memory).+blenViaPut :: Put a => a -> BLenT+blenViaPut = blen . runPut

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-} -- for CBLen  module Binrep.BLen   ( module Binrep.BLen@@ -6,40 +7,66 @@   ) where  import Binrep.BLen.Internal.AsBLen-import Binrep.CBLen import Binrep.Util ( natVal'' ) -import GHC.TypeNats+import GHC.TypeLits+ import Data.ByteString qualified as B+ import Data.Word import Data.Int +import Data.Void ( Void, absurd )+ type BLenT = Int --- | The length in bytes of a value of the given type can be known on the cheap---   e.g. by reading a length field, or using compile time information.------ Concepts such as null padding require the notion of length in bytes in order--- to handle. In a hand-rolled parser, you may keep count of the current length--- as you go. Here, the individual types keep track, and expose it via this--- typeclass.------ Obtaining the length of a value is usually an @O(1)@ operation like reading a--- field or returning a constant. When it's not, it's often an indicator of a--- problematic type e.g. plain Haskell lists.------ We derive a default instance for constant-size types by throwing away the--- value and reifying the type level natural.------ Note that one can derive a free 'BLen' instance for any type with a 'Put'--- instance via serializing it and checking the length. _Do not do this._ If you--- find you can't write a decent 'BLen' instance for a type, it may be that you--- need to rethink the representation.+{- | The length in bytes of a value of the given type can be known on the cheap+     e.g. by reading a length field, or using compile time information.++Some binary representation building blocks require the notion of length in bytes+in order to handle, e.g. null padding. One may always obtain this by serializing+the value, then reading out the length of the output bytestring. But in most+cases, we can be much more efficient.++  * Certain primitives have a size known at compile time, irrelevant of the+    value. A 'Word64' is always 8 bytes; some data null-padded to @n@ bytes is+    exactly @n@ bytes long.+  * For simple ADTs, it's often possible to calculate length in bytes via+    pattern matching and some numeric operations. Very little actual work.++This type class enables each type to implement its own efficient method of byte+length calculation. Aim to write something that plainly feels more efficient+than full serialization. If that doesn't feel possible, you might be working+with a type ill-suited for binary representation.++A thought: Some instances could be improved by reifying 'CBLen'. But it would+mess up all the deriving, and it feels like too minor an improvement to be+worthwhile supporting, writing a bunch of newtype wrappers, etc.+-} class BLen a where+    -- | The length in bytes of the serialized value.+    --+    -- The default implementation reifies the constant length for the type. If a+    -- type-wide constant length is not defined, it will fail at compile time.     blen :: a -> BLenT     default blen :: KnownNat (CBLen a) => a -> BLenT     blen _ = cblen @a +    -- | The length in bytes of any value of the given type is constant.+    --+    -- Many binary representation primitives are constant, or may be designed to+    -- "store" their size in their type. This is a stronger statement about+    -- their length than just 'blen'.+    --+    -- This is now an associated type family of the 'BLen' type class in hopes+    -- of simplifying the binrep framework.+    type CBLen a :: Natural+    type CBLen a =+        TypeError+            (       'Text "No CBLen associated family instance defined for "+              ':<>: 'ShowType a+            )+ typeNatToBLen :: forall n. KnownNat n => BLenT typeNatToBLen = natToBLen $ natVal'' @n {-# INLINE typeNatToBLen #-}@@ -49,6 +76,10 @@ cblen = typeNatToBLen @n {-# INLINE cblen #-} +-- | Impossible to put a byte length to 'Void'.+instance BLen Void where+    blen = absurd+ -- | @O(n)@ instance BLen a => BLen [a] where     blen = sum . map blen@@ -59,11 +90,22 @@ instance BLen B.ByteString where     blen = posIntToBLen . B.length -deriving anyclass instance BLen Word8-deriving anyclass instance BLen  Int8-deriving anyclass instance BLen Word16-deriving anyclass instance BLen  Int16-deriving anyclass instance BLen Word32-deriving anyclass instance BLen  Int32-deriving anyclass instance BLen Word64-deriving anyclass instance BLen  Int64+instance BLen Word8  where type CBLen Word8  = 1+instance BLen  Int8  where type CBLen  Int8  = 1+instance BLen Word16 where type CBLen Word16 = 2+instance BLen  Int16 where type CBLen  Int16 = 2+instance BLen Word32 where type CBLen Word32 = 4+instance BLen  Int32 where type CBLen  Int32 = 4+instance BLen Word64 where type CBLen Word64 = 8+instance BLen  Int64 where type CBLen  Int64 = 8++--------------------------------------------------------------------------------++-- | Newtype wrapper for defining 'BLen' instances which are allowed to assume+--   the existence of a valid 'CBLen' family instance.+newtype WithCBLen a = WithCBLen { unWithCBLen :: a }++instance KnownNat (CBLen a) => BLen (WithCBLen [a]) where+    blen (WithCBLen l) = cblen @a * length l+instance KnownNat (CBLen a + CBLen b) => BLen (WithCBLen (a, b)) where+    type CBLen (WithCBLen (a, b)) = CBLen a + CBLen b

@@ -1,21 +0,0 @@-module Binrep.CBLen where--import Data.Word-import Data.Int-import GHC.TypeNats ( Natural )---- | The length in bytes of any value of the given type is constant.------ Many binary representation primitives are constant, or store their size in--- their type. This is a stronger statement about their length than @BLen@.-type family CBLen a :: Natural---- Explicitly-sized Haskell machine words are constant size.-type instance CBLen Word8  = 1-type instance CBLen  Int8  = 1-type instance CBLen Word16 = 2-type instance CBLen  Int16 = 2-type instance CBLen Word32 = 4-type instance CBLen  Int32 = 4-type instance CBLen Word64 = 8-type instance CBLen  Int64 = 8

@@ -11,25 +11,25 @@ import GHC.Generics ( Generic ) import Data.Data ( Data ) -brCfgNoSum :: BR.Cfg (I 'U 'I1 'LE)-brCfgNoSum = BR.Cfg { BR.cSumTag = undefined }+import Data.Void ( Void )  data DV     deriving stock (Generic, Data)  -- Disallowed. No binrepping void datatypes. {--instance BLen DV where blen = blenGeneric brCfgNoSum-instance Put  DV where put  = putGeneric  brCfgNoSum-instance Get  DV where get  = getGeneric  brCfgNoSum+instance BLen DV where blen = blenGeneric BR.cNoSum+instance Put  DV where put  = putGeneric  BR.cNoSum+instance Get  DV where get  = getGeneric  BR.cNoSum -}  data DU = DU     deriving stock (Generic, Data, Show, Eq) -instance BLen DU where blen = blenGeneric brCfgNoSum-instance Put  DU where put  = putGeneric  brCfgNoSum-instance Get  DU where get  = getGeneric  brCfgNoSum+--instance BLen DU where blen = blenGeneric BR.cNoSum+instance BLen DU where type CBLen DU = CBLenGeneric Void DU+instance Put  DU where put  = putGeneric  cNoSum+instance Get  DU where get  = getGeneric  cNoSum  data DSS = DSS   { dss1 :: I 'U 'I1 'LE@@ -39,29 +39,27 @@   , dss5 :: I 'U 'I1 'LE   } deriving stock (Generic, Data, Show, Eq) -instance BLen DSS where blen = blenGeneric brCfgNoSum-instance Put  DSS where put  = putGeneric  brCfgNoSum-instance Get  DSS where get  = getGeneric  brCfgNoSum+instance BLen DSS where blen = blenGeneric cNoSum+--instance BLen DSS where type CBLen DSS = CBLenGeneric Void DSS+instance Put  DSS where put  = putGeneric  cNoSum+instance Get  DSS where get  = getGeneric  cNoSum  data DCS = DCS1 {- DSS -} | DCS2 | DCS3 | DCS4 | DCS5     deriving stock (Generic, Data, Show, Eq) -brCfgDCS :: BR.Cfg (I 'U 'I1 'LE)-brCfgDCS = BR.Cfg { BR.cSumTag = BR.cSumTagHex $ drop 3 }+type BrSumDCS = I 'U 'I1 'LE+brCfgDCS :: BR.Cfg BrSumDCS+brCfgDCS = BR.cfg $ BR.cSumTagHex $ drop 3 ---instance BR.BLen DCS where blen = BR.blenGeneric brCfgDCS-deriving anyclass instance BLen DCS+--instance BLen DCS where blen = BR.blenGeneric brCfgDCS+instance BLen DCS where type CBLen DCS = CBLenGeneric BrSumDCS DCS instance Put  DCS where put  = putGeneric  brCfgDCS instance Get  DCS where get  = getGeneric  brCfgDCS  data DX = DX DU     deriving stock (Generic, Data, Show, Eq) -type instance CBLen DX  = CBLenGeneric (I 'U 'I1 'LE) DX-type instance CBLen DU  = CBLenGeneric (I 'U 'I1 'LE) DU-type instance CBLen DSS = CBLenGeneric (I 'U 'I1 'LE) DSS-type instance CBLen DCS = CBLenGeneric (I 'U 'I1 'LE) DCS-deriving anyclass instance BLen DX---- TODO clean up that CBLen messing around, probably don't mention it outside--- the module (it's weird and will probably break things)+--instance BLen DX where blen = blenGeneric brCfgNoSum+instance BLen DX where type CBLen DX = CBLenGeneric Void DX+instance Put  DX where put  = putGeneric  cNoSum+instance Get  DX where get  = getGeneric  cNoSum

@@ -2,9 +2,6 @@  import Binrep import Binrep.Generic-import Binrep.Generic qualified as BR-import Binrep.Type.Common ( Endianness(..) )-import Binrep.Type.Int import Binrep.Type.NullPadded import Binrep.Type.AsciiNat @@ -20,9 +17,6 @@  type BS = B.ByteString -brCfgNoSum :: BR.Cfg (I 'U 'I1 'LE)-brCfgNoSum = BR.Cfg { BR.cSumTag = undefined }- -- | The naturals in tars are sized octal ASCII digit strings that end with a --   null byte (and may start with leading ASCII zeroes). The size includes the --   terminating null, so you get @n-1@ digits. What a farce.@@ -32,8 +26,8 @@ newtype TarNat n = TarNat { getTarNat :: AsciiNat 8 }     deriving stock (Generic, Show, Eq) -type instance CBLen (TarNat n) = n-instance KnownNat n => BLen (TarNat n)+instance KnownNat n => BLen (TarNat n) where+    type CBLen (TarNat n) = n  -- | No need to check for underflow etc. as TarNat guarantees good sizing. instance KnownNat n => Put (TarNat n) where@@ -48,7 +42,7 @@         an <- FP.isolate (fromIntegral (n - 1)) get         get @Word8 >>= \case           0x00 -> return $ TarNat an-          w    -> FP.err $ "TODO expected null byte, got " <> show w+          w    -> eBase $ EExpectedByte 0x00 w       where         n = typeNatToBLen @n @@ -62,6 +56,6 @@   , tarFileLastMod :: TarNat 12   } deriving stock (Generic, Show, Eq) -instance BLen Tar where blen = blenGeneric brCfgNoSum-instance Put  Tar where put  = putGeneric  brCfgNoSum-instance Get  Tar where get  = getGeneric  brCfgNoSum+instance BLen Tar where blen = blenGeneric cNoSum+instance Put  Tar where put  = putGeneric  cNoSum+instance Get  Tar where get  = getGeneric  cNoSum

@@ -5,7 +5,6 @@  import Binrep import Binrep.Generic-import Binrep.Generic qualified as BR import Binrep.Type.Common ( Endianness(..) ) import Binrep.Type.Int import Binrep.Type.Magic@@ -20,11 +19,8 @@  type W8 = I 'U 'I1 'LE -brCfgNoSum :: BR.Cfg W8-brCfgNoSum = BR.Cfg { BR.cSumTag = undefined }- data Tiff where-    Tiff :: (Put (I 'U 'I4 end), bs ~ MagicVals (TiffMagic end), ByteVals bs, KnownNat (Length bs)) => TiffBody end -> Tiff+    Tiff :: (Put (I 'U 'I4 end), bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, KnownNat (Length bs)) => TiffBody end -> Tiff  instance Show Tiff where     show (Tiff body) = "Tiff " <> show body@@ -35,12 +31,12 @@   } deriving stock (Generic, Show, Eq) deriving stock instance (KnownSymbol (TiffMagic end), Typeable end) => Data (TiffBody end) -instance (bs ~ MagicVals (TiffMagic end), KnownNat (Length bs)) => BLen (TiffBody end) where-    blen = blenGeneric brCfgNoSum-instance (bs ~ MagicVals (TiffMagic end), ByteVals bs, irep ~ I 'U 'I4 end, Put irep) => Put  (TiffBody end) where-    put  = putGeneric  brCfgNoSum-instance (bs ~ MagicVals (TiffMagic end), ByteVals bs, irep ~ I 'U 'I4 end, Get irep) => Get  (TiffBody end) where-    get  = getGeneric  brCfgNoSum+instance (bs ~ MagicBytes (TiffMagic end), KnownNat (Length bs)) => BLen (TiffBody end) where+    blen = blenGeneric cNoSum+instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Put irep) => Put  (TiffBody end) where+    put  = putGeneric  cNoSum+instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Get irep) => Get  (TiffBody end) where+    get  = getGeneric  cNoSum  instance BLen Tiff where     blen (Tiff body) = blen body

@@ -2,7 +2,6 @@  import Binrep import Binrep.Generic-import Binrep.Generic qualified as BR import Binrep.Type.Common ( Endianness(..) ) import Binrep.Type.Int import Binrep.Type.Magic@@ -10,12 +9,9 @@ import GHC.Generics ( Generic ) import Data.Data ( Data ) -type E = 'LE-type W32 = I 'U 'I4 E-type W16 = I 'U 'I2 E--brCfgNoSum :: BR.Cfg (I 'U 'I1 'LE)-brCfgNoSum = BR.Cfg { BR.cSumTag = undefined }+type End = 'LE+type W32 = I 'U 'I4 End+type W16 = I 'U 'I2 End  data WavHeader = WavHeader   { wavHeaderMagic :: Magic "RIFF"@@ -26,6 +22,6 @@   , wavHeaderChannels :: W16   } deriving stock (Generic, Data, Show, Eq) -instance BLen WavHeader where blen = blenGeneric brCfgNoSum-instance Put  WavHeader where put  = putGeneric  brCfgNoSum-instance Get  WavHeader where get  = getGeneric  brCfgNoSum+instance BLen WavHeader where blen = blenGeneric cNoSum+instance Put  WavHeader where put  = putGeneric  cNoSum+instance Get  WavHeader where get  = getGeneric  cNoSum

@@ -1,8 +1,9 @@ -- | Derive 'BLen', 'Put', 'Get' and 'CBLen' instances generically.  module Binrep.Generic-  ( Cfg(..)+  ( Cfg(..), cfg   , cSumTagHex, cSumTagNullTerm, cDef+  , cNoSum, EDerivedSumInstanceWithNonSumCfg(..)   , blenGeneric, putGeneric, getGeneric, CBLenGeneric   ) where @@ -19,8 +20,14 @@  import Numeric ( readHex ) --- TODO better error handling (see what aeson does)+import Data.Void ( Void )+import Control.Exception ( Exception, throw ) +import Binrep.Util ( tshow )++cfg :: (Eq a, Show a) => (String -> a) -> Cfg a+cfg f = Cfg { cSumTag = f, cSumTagEq = (==), cSumTagShow = tshow }+ -- | Obtain the tag for a sum type value by applying a function to the --   constructor name, and reading the result as a hexadecimal number. cSumTagHex :: forall a. Integral a => (String -> String) -> String -> a@@ -45,5 +52,28 @@ cSumTagNullTerm :: String -> AsByteString 'C cSumTagNullTerm = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack +-- | Default generic derivation configuration, using 'cSumTagNullTerm'. cDef :: Cfg (AsByteString 'C)-cDef = Cfg { cSumTag = cSumTagNullTerm }+cDef = cfg cSumTagNullTerm++-- | Special generic derivation configuration you may use for non-sum data+--   types.+--+-- When generically deriving binrep instances for a non-sum type, you may like+-- to ignore sum tag handling. You could use 'cDef', but this will silently+-- change behaviour if your type becomes a sum type. This configuration will+-- generate clear runtime errors when used with a sum type.+--+-- By selecting 'Void' for the sum tag type, consumption actions (serializing,+-- getting length in bytes) will runtime error, while generation actions+-- (parsing) will hit the 'Void' instance first and always safely error out.+cNoSum :: Cfg Void+cNoSum = cfg $ \_ -> throw EDerivedSumInstanceWithNonSumCfg++-- This indirection enables us to test for this precise exception being thrown+-- in an incorrect configuration! Awesome!+data EDerivedSumInstanceWithNonSumCfg = EDerivedSumInstanceWithNonSumCfg+instance Show EDerivedSumInstanceWithNonSumCfg where+    show EDerivedSumInstanceWithNonSumCfg =+        "Binrep.Generic.cNoSum: non-sum generic derivation configuration used with a sum type"+instance Exception EDerivedSumInstanceWithNonSumCfg

@@ -7,6 +7,7 @@  import Binrep.BLen import Binrep.Generic.Internal+import Util.Generic  blenGeneric :: (Generic a, GBLen (Rep a), BLen w) => Cfg w -> a -> BLenT blenGeneric cfg = gblen cfg . from

@@ -1,33 +1,31 @@ {-# LANGUAGE UndecidableInstances #-} -{- | Generically derive 'CBLen' type family instances.--This is mostly playing around -- I've only just learned regular GHC generics,-and pulling everything up to the type level is even more confusing and weird.+{- | _Experimental._ Generically derive 'CBLen' type family instances. -A 'CBLen' instance usually indicates a type is either extremely simple or comes-with size information in the type. Be careful deriving or writing instances for-your own types - @BLen@ is usually correct/sufficient.+A type having a valid 'CBLen' instance usually indicates one of the following: -You can attempt to derive a 'CBLen' type family instance generically for a type-via+  * it's a primitive, or extremely simple+  * it holds size information in its type+  * it's constructed from other constant byte length types -    type instance CBLen a = CBLenGeneric w a+The first two cases must be handled manually. The third case is where Haskell+generics excel, and the one this module targets. -As with deriving @BLen@, you must provide the type used to store the sum tag for-sum types.+You can (attempt to) derive a 'CBLen' type family instance generically for a+type via -Then try doing something with it e.g. have GHC derive a @BLen@ instance for you-via the default method (that reifies CBLen)+    instance BLen a where type CBLen a = CBLenGeneric w a -    deriving anyclass BLen a+As with deriving @BLen@ generically, you must provide the type used to store the+sum tag for sum types. -Hopefully it either compiles, or you get a useful type error. If not, sorry.+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.Generic.CBLen where -import Binrep.CBLen+import Binrep.BLen import Binrep.Generic.Internal  import GHC.Generics

@@ -7,60 +7,81 @@  import Binrep.Get import Binrep.Generic.Internal+import Util.Generic  import FlatParse.Basic qualified as FP-import FlatParse.Basic ( Parser ) import Control.Applicative ( (<|>) ) -getGeneric :: (Generic a, GGet (Rep a), Get w, Eq w, Show w) => Cfg w -> Parser String a-getGeneric cfg = to <$> gget cfg+import Numeric.Natural -class GGet f where-    gget :: (Get w, Eq w, Show w) => Cfg w -> Parser String (f a)+getGeneric :: (Generic a, GGetD (Rep a), Get w) => Cfg w -> Getter a+getGeneric cfg = to <$> ggetD cfg --- | Empty constructor.-instance GGet U1 where-    gget _ = return U1+class GGetD f where+    ggetD :: Get w => Cfg w -> Getter (f a) --- | Field.-instance Get c => GGet (K1 i c) where-    gget _ = K1 <$> get+instance (GGetC f, Datatype d) => GGetD (D1 d f) where+    ggetD cfg = M1 <$> ggetC cfg (datatypeName' @d) --- | Product type fields are consecutive.-instance (GGet l, GGet r) => GGet (l :*: r) where-    gget cfg = do l <- gget cfg-                  r <- gget cfg-                  return $ l :*: r+class GGetC f where+    ggetC :: Get w => Cfg w -> String -> Getter (f a) --- | Constructor sums are differentiated by a prefix tag.-instance GGetSum (l :+: r) => GGet (l :+: r) where-    gget cfg = do-        tag <- get-        case ggetsum cfg tag of-          Just parser -> parser-          Nothing -> FP.err $ "invalid sum type tag: "<>show tag+-- | Refuse to derive instance for empty data types.+instance TypeError GErrRefuseVoid => GGetC V1 where+    ggetC = undefined --- | Refuse to derive instance for void datatype.-instance TypeError GErrRefuseVoid => GGet V1 where-    gget = undefined+-- | TODO: Non-sum data types.+instance (GGetS f, Constructor c) => GGetC (C1 c f) where+    ggetC cfg dStr = (M1 . snd) <$> ggetS cfg dStr (conName' @c) 0 --- | Any datatype, constructor or record.-instance GGet f => GGet (M1 i d f) where-    gget cfg = M1 <$> gget cfg+class GGetS f where+    ggetS :: Get w => Cfg w -> String -> String -> Natural -> Getter (Natural, (f a)) +-- | The empty constructor trivially succeeds without parsing anything.+instance GGetS U1 where+    ggetS _ _ _ fIdx = pure (fIdx, U1)++instance (GGetS l, GGetS r) => GGetS (l :*: r) where+    ggetS cfg dStr cStr fIdx = do+        (fIdx',  l) <- ggetS cfg dStr cStr fIdx+        (fIdx'', r) <- ggetS cfg dStr cStr (fIdx'+1)+        pure (fIdx'', l :*: r)++instance (Get a, Selector s) => GGetS (S1 s (Rec0 a)) where+    ggetS _ dStr cStr fIdx = do+        a <- getEWrap $ EGeneric dStr . EGenericField cStr sStr fIdx+        pure (fIdx, M1 (K1 a))+      where+        sStr = selName'' @s+ -------------------------------------------------------------------------------- -class GGetSum f where-    ggetsum :: (Get w, Eq w, Show w) => Cfg w -> w -> Maybe (Parser String (f a))+-- | Constructor sums are differentiated by a prefix tag.+instance GGetCSum (l :+: r) => GGetC (l :+: r) where+    ggetC cfg dStr = do+        tag <- getEWrap $ EGeneric dStr . EGenericSum . EGenericSumTag+        case ggetCSum cfg dStr tag of+          Just parser -> parser+          Nothing -> do+            let tagPretty = cSumTagShow cfg $ tag+            FP.err $ EGeneric dStr $ EGenericSum $ EGenericSumTagNoMatch [] tagPretty -instance (GGetSum l, GGetSum r) => GGetSum (l :+: r) where-    ggetsum cfg tag = l <|> r+-- | TODO: Want to return an @Either [(String, Text)]@ indicating the+-- constructors and their expected tags tested, but needs fiddling (can't use+-- 'Alternative'). Pretty minor, but Aeson does it and it's nice.+class GGetCSum f where+    ggetCSum :: Get w => Cfg w -> String -> w -> Maybe (Getter (f a))++instance (GGetCSum l, GGetCSum r) => GGetCSum (l :+: r) where+    ggetCSum cfg dStr tag = l <|> r       where-        l = fmap L1 <$> ggetsum cfg tag-        r = fmap R1 <$> ggetsum cfg tag+        l = fmap L1 <$> ggetCSum cfg dStr tag+        r = fmap R1 <$> ggetCSum cfg dStr tag --- | Bad. Need to wrap this like SumFromString in Aeson.-instance (GGet r, Constructor c) => GGetSum (C1 c r) where-    ggetsum cfg tag-     | tag == (cSumTag cfg) (conName' @c) = Just $ gget cfg-     | otherwise = Nothing+instance (GGetS f, Constructor c) => GGetCSum (C1 c f) where+    ggetCSum cfg dStr tag =+        let cStr = conName' @c+            cTag = (cSumTag cfg) cStr+        in  if   (cSumTagEq cfg) tag cTag+            then Just ((M1 . snd) <$> ggetS cfg dStr cStr 0)+            else Nothing

@@ -1,21 +1,17 @@-{-# LANGUAGE AllowAmbiguousTypes #-}- module Binrep.Generic.Internal where  import GHC.TypeLits-import GHC.Generics+import Data.Text ( Text )  data Cfg a = Cfg   { cSumTag :: String -> a   -- ^ How to turn a constructor name into a byte tag.++  , cSumTagEq   :: a -> a -> Bool+  , cSumTagShow :: a -> Text   }  -- | Common type error string for when GHC attempts to derive an binrep instance --   for a (the?) void datatype @V1@. type GErrRefuseVoid =     'Text "Refusing to derive binary representation for void datatype"---- | 'conName' without the value (only used as a proxy). Lets us push our---   'undefined's into one place.-conName' :: forall c. Constructor c => String-conName' = conName @c undefined

@@ -7,6 +7,7 @@  import Binrep.Put import Binrep.Generic.Internal+import Util.Generic  putGeneric :: (Generic a, GPut (Rep a), Put w) => Cfg w -> a -> Builder putGeneric cfg = gput cfg . from

@@ -2,37 +2,111 @@  module Binrep.Get   ( Getter, Get(..), runGet, runGetter+  , E(..), EBase(..), EGeneric(..), EGenericSum(..)+  , eBase+  , getEWrap, getEBase+  , cutEBase   , GetWith(..), runGetWith   ) where  import FlatParse.Basic qualified as FP-import FlatParse.Basic ( Parser )+ import Data.ByteString qualified as B++import GHC.Exts ( TYPE, type LiftedRep )+ import Data.Word import Data.Int-import GHC.Exts+import Data.Void ( Void ) -type Getter a = Parser String a+import GHC.Generics ( Generic ) +import Data.Text ( Text )++import Binrep.BLen ( BLenT )++import Numeric.Natural++type Getter a = FP.Parser E a++data E+  = EBase EBase++  | EGeneric String {- ^ datatype name -} EGeneric++    deriving stock (Eq, Show, Generic)++eBase :: EBase -> Getter a+eBase = FP.err . EBase++-- | TODO confirm correct operation (error combination)+getEWrap :: Get a => (E -> E) -> Getter a+getEWrap f = FP.cutting get (f $ EBase EFail) (\e _ -> f e)++getEBase :: Get a => EBase -> Getter a+getEBase = FP.cut get . EBase++cutEBase :: Getter a -> EBase -> Getter a+cutEBase f e = FP.cut f $ EBase e++data EBase+  = ENoVoid+  | EFail+  | EEof++  | EExpectedByte Word8 Word8+  -- ^ expected first, got second++  | EOverlong BLenT BLenT+  -- ^ 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 Natural+  -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0)++    deriving stock (Eq, Show, Generic)++data EGeneric+  = EGenericSum EGenericSum+  | EGenericField String (Maybe String) Natural E+    deriving stock (Eq, Show, Generic)++data EGenericSum+  = EGenericSumTag E+  | EGenericSumTagNoMatch [String] Text+    deriving stock (Eq, Show, Generic)+ class Get a where     -- | Parse from binary.     get :: Getter a -runGet :: Get a => B.ByteString -> Either String (a, B.ByteString)+runGet :: Get a => B.ByteString -> Either E (a, B.ByteString) runGet = runGetter get -runGetter :: Getter a -> B.ByteString -> Either String (a, B.ByteString)+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 "TODO fail"+                   FP.Fail     -> Left $ EBase EFail                    FP.Err e    -> Left e +-- | Impossible to parse 'Void'.+instance Get Void where+    get = eBase ENoVoid+ -- | Parse heterogeneous lists in order. No length indicator, so either fails or --   succeeds by reaching EOF. Probably not what you usually want, but sometimes --   used at the "top" of binary formats. instance Get a => Get [a] where     get = do as <- FP.many get-             FP.eof+             cutEBase FP.eof EEof              return as  instance (Get a, Get b) => Get (a, b) where@@ -44,8 +118,8 @@ instance Get B.ByteString where     get = FP.takeRestBs -instance Get Word8 where get = FP.anyWord8-instance Get  Int8 where get = FP.anyInt8+instance Get Word8 where get = cutEBase FP.anyWord8 (ERanOut 1)+instance Get  Int8 where get = cutEBase FP.anyInt8  (ERanOut 1)  -- | A type that can be parsed from binary given some environment. --@@ -64,5 +138,5 @@ -- can't bind (LHS) a levity polymorphic value. runGetWith     :: GetWith (r :: TYPE LiftedRep) a-    => r -> B.ByteString -> Either String (a, B.ByteString)+    => r -> B.ByteString -> Either E (a, B.ByteString) runGetWith r bs = runGetter (getWith r) bs

@@ -3,8 +3,10 @@ import Mason.Builder qualified as Mason  import Data.ByteString qualified as B+ import Data.Word import Data.Int+import Data.Void ( Void, absurd )  type Builder = Mason.BuilderFor Mason.StrictByteStringBackend @@ -18,6 +20,10 @@  runBuilder :: Builder -> B.ByteString runBuilder = Mason.toStrictByteString++-- | 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

@@ -30,8 +30,6 @@ import Data.Data ( Data ) import Numeric ( showOct, showHex, showBin, showInt ) -import FlatParse.Basic qualified as FP- -- | A 'Natural' represented in binary as an ASCII string, where each character --   a is a digit in the given base (> 1). --@@ -66,8 +64,8 @@     get = do         bs <- get         case asciiBytesToNat octalFromAsciiDigit 8 bs of-          Left bs' -> FP.err $ "TODO " <> show bs'-          Right n  -> return $ AsciiNat n+          Left  w -> eBase $ EFailParse "hex ASCII natural" bs w+          Right n -> return $ AsciiNat n  octalFromAsciiDigit :: Word8 -> Maybe Word8 octalFromAsciiDigit = \case

@@ -801,21 +801,25 @@     Length '[]       = 0     Length (a ': as) = 1 + Length as --- | Efficiently reify a list of type-level 'Byte's to a bytestring builder.+-- | 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 ByteVals (ns :: [Natural]) where byteVals :: Builder-instance (n ~ Length ns, KnownNat n, WriteByteVals ns) => ByteVals ns where-    byteVals = Mason.primFixed (BI.fixedPrim (fromIntegral n) go) ()+class ReifyBytes (ns :: [Natural]) where reifyBytes :: Builder+instance (n ~ Length ns, KnownNat n, WriteReifiedBytes ns) => ReifyBytes ns where+    reifyBytes = Mason.primFixed (BI.fixedPrim (fromIntegral n) go) ()       where         n = natVal'' @n-        go = \() (Ptr p#) -> writeByteVals @ns p#+        go = \() (Ptr p#) -> writeReifiedBytes @ns p# -class WriteByteVals (ns :: [Natural]) where writeByteVals :: Addr# -> IO ()-instance WriteByteVals '[] where writeByteVals _ = pure ()-instance (ByteVal n, WriteByteVals ns) => WriteByteVals (n ': ns) where-    writeByteVals p# =+-- bit ugly+class WriteReifiedBytes (ns :: [Natural]) where writeReifiedBytes :: Addr# -> IO ()+instance WriteReifiedBytes '[] where writeReifiedBytes _ = pure ()+instance (ByteVal n, WriteReifiedBytes ns) => WriteReifiedBytes (n ': ns) where+    writeReifiedBytes p# =         case runRW# (writeWord8OffAddr# p# 0# w#) of-          _ -> writeByteVals @ns (plusAddr# p# 1#)+          _ -> writeReifiedBytes @ns (plusAddr# p# 1#)       where w# = byteVal @n proxy#

@@ -27,7 +27,6 @@  import Data.ByteString qualified as B import FlatParse.Basic qualified as FP-import FlatParse.Basic ( Parser ) import Data.Word ( Word8 ) import GHC.TypeNats ( KnownNat ) @@ -50,8 +49,8 @@ -- | A bytestring using the given representation, stored in the 'Text' type. type AsByteString (rep :: Rep) = Refined rep B.ByteString -getCString :: Parser String B.ByteString-getCString = FP.anyCString+getCString :: Getter B.ByteString+getCString = FP.cut FP.anyCString $ EBase $ EFailNamed "cstring"  instance BLen (AsByteString 'C) where     blen cbs = posIntToBLen $ B.length (unrefine cbs) + 1

@@ -90,9 +90,8 @@ deriving via (IRep sign size) instance ToJSON   (IRep sign size) => ToJSON   (I sign size e) deriving via (IRep sign size) instance FromJSON (IRep sign size) => FromJSON (I sign size e) -type instance CBLen (I sign size end) = CBLen (IRep sign size)--deriving anyclass instance KnownNat (CBLen (I sign size end)) => BLen (I sign size end)+instance KnownNat (CBLen (I sign size end)) => BLen (I sign size end) where+    type CBLen (I sign size end) = CBLen (IRep sign size)  instance Put (I 'U 'I1 e) where put = put . getI instance Get (I 'U 'I1 e) where get = I <$> get@@ -100,31 +99,31 @@ instance Get (I 'S 'I1 e) where get = I <$> get  instance Put (I 'U 'I2 'BE) where put (I i) = Mason.word16BE i-instance Get (I 'U 'I2 'BE) where get = I <$> FP.anyWord16be+instance Get (I 'U 'I2 'BE) where get = I <$> cutEBase FP.anyWord16be (ERanOut 2) instance Put (I 'U 'I2 'LE) where put (I i) = Mason.word16LE i-instance Get (I 'U 'I2 'LE) where get = I <$> FP.anyWord16le+instance Get (I 'U 'I2 'LE) where get = I <$> cutEBase FP.anyWord16le (ERanOut 2) instance Put (I 'S 'I2 'BE) where put (I i) = Mason.int16BE i-instance Get (I 'S 'I2 'BE) where get = I <$> FP.anyInt16be+instance Get (I 'S 'I2 'BE) where get = I <$> cutEBase FP.anyInt16be  (ERanOut 2) instance Put (I 'S 'I2 'LE) where put (I i) = Mason.int16LE i-instance Get (I 'S 'I2 'LE) where get = I <$> FP.anyInt16le+instance Get (I 'S 'I2 'LE) where get = I <$> cutEBase FP.anyInt16le  (ERanOut 2)  instance Put (I 'U 'I4 'BE) where put (I i) = Mason.word32BE i-instance Get (I 'U 'I4 'BE) where get = I <$> FP.anyWord32be+instance Get (I 'U 'I4 'BE) where get = I <$> cutEBase FP.anyWord32be (ERanOut 4) instance Put (I 'U 'I4 'LE) where put (I i) = Mason.word32LE i-instance Get (I 'U 'I4 'LE) where get = I <$> FP.anyWord32le+instance Get (I 'U 'I4 'LE) where get = I <$> cutEBase FP.anyWord32le (ERanOut 4) instance Put (I 'S 'I4 'BE) where put (I i) = Mason.int32BE i-instance Get (I 'S 'I4 'BE) where get = I <$> FP.anyInt32be+instance Get (I 'S 'I4 'BE) where get = I <$> cutEBase FP.anyInt32be  (ERanOut 4) instance Put (I 'S 'I4 'LE) where put (I i) = Mason.int32LE i-instance Get (I 'S 'I4 'LE) where get = I <$> FP.anyInt32le+instance Get (I 'S 'I4 'LE) where get = I <$> cutEBase FP.anyInt32le  (ERanOut 4)  instance Put (I 'U 'I8 'BE) where put (I i) = Mason.word64BE i-instance Get (I 'U 'I8 'BE) where get = I <$> FP.anyWord64be+instance Get (I 'U 'I8 'BE) where get = I <$> cutEBase FP.anyWord64be (ERanOut 8) instance Put (I 'U 'I8 'LE) where put (I i) = Mason.word64LE i-instance Get (I 'U 'I8 'LE) where get = I <$> FP.anyWord64le+instance Get (I 'U 'I8 'LE) where get = I <$> cutEBase FP.anyWord64le (ERanOut 8) instance Put (I 'S 'I8 'BE) where put (I i) = Mason.int64BE i-instance Get (I 'S 'I8 'BE) where get = I <$> FP.anyInt64be+instance Get (I 'S 'I8 'BE) where get = I <$> cutEBase FP.anyInt64be  (ERanOut 8) instance Put (I 'S 'I8 'LE) where put (I i) = Mason.int64LE i-instance Get (I 'S 'I8 'LE) where get = I <$> FP.anyInt64le+instance Get (I 'S 'I8 'LE) where get = I <$> cutEBase FP.anyInt64le  (ERanOut 8)  -- | Shortcut. type family IMax (sign :: ISign) (size :: ISize) :: Natural where

@@ -1,11 +1,8 @@ {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}  {- | Magic numbers (also just magic): short constant bytestrings usually-     found at the top of a file, included as a safety check for parsing.--TODO rename: MagicBytes -> MagicVals, and have ByteVal be a "consumer" of-MagicVals where each value must be a byte. (It's conceivable that we have-another consumer which makes each value into a non-empty list of bytes, LE/BE.)+     found at the top of a file, often used as an early sanity check.  TODO unassociated type fams bad (maybe). turn into class -- and turn the reifier into a default method! (TODO think about this)@@ -41,29 +38,41 @@  import Mason.Builder qualified as Mason +import Strongweak++-- | An empty data type representing a magic number (a constant bytestring) via+--   a phantom type.+--+-- The phantom type variable unambiguously defines a short, 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) --- | Assumes magic values are individual bytes.-type instance CBLen (Magic a) = Length (MagicVals a)+-- | 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.+instance Weaken (Magic a) where+    type Weak (Magic a) = ()+    weaken _ = () --- | Assumes magic values are individual bytes.-deriving anyclass instance KnownNat (Length (MagicVals a)) => BLen (Magic a)+-- | Strengthen the unit to some 'Magic a'.+instance Strengthen (Magic a) where+    strengthen _ = pure Magic --- | Forces magic values to be individual bytes.-instance (bs ~ MagicVals a, ByteVals bs) => Put (Magic a) where-    put Magic = byteVals @bs+instance (KnownNat (Length (MagicBytes a))) => BLen (Magic a) where+    type CBLen (Magic a) = Length (MagicBytes a) --- | Forces magic values to be individual bytes.------ TODO improve show - maybe hexbytestring goes here? lol-instance (bs ~ MagicVals a, ByteVals bs) => Get (Magic a) where+instance (bs ~ MagicBytes a, ReifyBytes bs) => Put (Magic a) where+    put Magic = reifyBytes @bs++instance (bs ~ MagicBytes a, ReifyBytes bs) => Get (Magic a) where     get = do-        let expected = Mason.toStrictByteString $ byteVals @bs+        let expected = Mason.toStrictByteString $ reifyBytes @bs         actual <- FP.takeBs $ B.length expected         if   actual == expected         then return Magic-        else FP.err $ "bad magic: expected "<>show expected<>", got "<>show actual+        else eBase $ EExpected expected actual  {- I do lots of functions on lists, because they're structurally simple. But you@@ -78,10 +87,6 @@ So you have to write that out for every concrete function over lists. -} -type family MagicVals (a :: k) :: [Natural]-type instance MagicVals (a :: Symbol)    = SymbolUnicodeCodepoints a-type instance MagicVals (a :: [Natural]) = a- type family SymbolUnicodeCodepoints (a :: Symbol) :: [Natural] where     SymbolUnicodeCodepoints a = CharListUnicodeCodepoints (SymbolAsCharList a) @@ -95,3 +100,20 @@ 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.+    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++-- | 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

@@ -41,7 +41,7 @@         actual <- FP.takeBs $ B.length expected         if   actual == expected         then return MagicUTF8-        else FP.err $ "bad magic: expected "<>show expected<>", got "<>show actual+        else eBase $ EExpected expected actual  encodeStringUtf8 :: String -> B.ByteString encodeStringUtf8 = Text.encodeUtf8 . Text.pack

@@ -19,10 +19,9 @@  type NullPadded n a = Refined (NullPad n) a --- | The size of some null-padded data is known - at compile time!-type instance CBLen (NullPadded n a) = n--deriving anyclass instance KnownNat n => BLen (NullPadded n a)+instance KnownNat n => BLen (NullPadded n a) where+    -- | The size of some null-padded data is known - at compile time!+    type CBLen (NullPadded n a) = n  instance (BLen a, KnownNat n) => Predicate (NullPad n) a where     validate p a@@ -58,13 +57,13 @@         let len = blen a             nullStrLen = n - len         if   nullStrLen < 0-        then FP.err $ "too long: " <> show len <> " > " <> show n+        then eBase $ EOverlong n len         else getNNulls nullStrLen >> return (reallyUnsafeRefine a)       where         n = typeNatToBLen @n -getNNulls :: BLenT -> Parser String ()+getNNulls :: BLenT -> Parser E () getNNulls = \case 0 -> return ()                   n -> FP.anyWord8 >>= \case                          0x00    -> getNNulls $ n-1-                         nonNull -> FP.err "TODO expected null, wasn't"+                         nonNull -> eBase $ EExpectedByte 0x00 nonNull

@@ -18,9 +18,7 @@  type Sized n a = Refined (Size n) a -type instance CBLen (Sized n a) = n--deriving anyclass instance KnownNat n => BLen (Sized n a)+instance KnownNat n => BLen (Sized n a) where type CBLen (Sized n a) = n  instance (BLen a, KnownNat n) => Predicate (Size n) a where     validate p a

@@ -8,7 +8,9 @@   , Encode, encode   , Decode(..)   , encodeToRep+#ifdef HAVE_ICU   , decodeViaTextICU+#endif   ) where  import Binrep.Type.Common ( Endianness(..) )@@ -33,7 +35,9 @@ import Control.Exception qualified import Data.Text.Encoding.Error qualified +#ifdef HAVE_ICU import Data.Text.ICU.Convert qualified as ICU+#endif  type Bytes = B.ByteString @@ -68,8 +72,6 @@ instance Encode ('UTF32 'BE) where encode' = Text.encodeUtf32BE instance Encode ('UTF32 'LE) where encode' = Text.encodeUtf32LE -instance Encode 'SJIS where encode' = encodeViaTextICU' "Shift-JIS"- -- | Encode some validated text. encode :: forall enc. Encode enc => AsText enc -> Bytes encode = encode' @enc . unrefine@@ -109,8 +111,6 @@ instance Decode 'ASCII where decode = decodeText $ wrapUnsafeDecoder Text.decodeASCII #endif -instance Decode 'SJIS where decode = decodeText id $ decodeViaTextICU' "Shift-JIS"- -------------------------------------------------------------------------------- -- Helpers @@ -154,6 +154,14 @@     . Control.Exception.evaluate     . f +--------------------------------------------------------------------------------+-- ICU++#ifdef HAVE_ICU+instance Encode 'SJIS where encode' = encodeViaTextICU' "Shift-JIS"+instance Decode 'SJIS where+    decode  = decodeText id $ decodeViaTextICU' "Shift-JIS"+ -- | Encode some 'Text' to the given character set using text-icu. -- -- No guarantees about correctness. Encodings are weird. e.g. Shift JIS's@@ -182,3 +190,4 @@ decodeViaTextICU' :: String -> B.ByteString -> Either String Text decodeViaTextICU' charset t = do     System.IO.Unsafe.unsafeDupablePerformIO $ decodeViaTextICU charset t+#endif

@@ -0,0 +1,136 @@+{- | Variable-length integers (varints), a method to store arbitrarily large+     integers in a space efficient manner.++Note that varints aren't particularly efficient due to their decoding being+slow. They are most interesting when you wish to provide support for large+integers, but know that many (most?) inputs will be small, and want to be space+efficient for them. Protocol Buffers uses them extensively, while Cap'n Proto+swears them off.++TODO++  * https://en.wikipedia.org/wiki/Variable-length_quantity+    * I've defined basic unsigned varints. Signed varints have lots of options.+      You can use twos comp, zigzag, a sign bit, whatever.+-}++{-# LANGUAGE AllowAmbiguousTypes #-}++module Binrep.Type.Varint where++import Binrep+import Binrep.Type.Common ( Endianness(..) )++import Data.Bits+import FlatParse.Basic qualified as FP++import Data.Word ( Word8 )++-- | A variable-length unsigned integer (natural).+--+-- The base algorithm is to split the natural into groups of 7 bits, and use the+-- MSB to indicate whether another octet follows. You must specify a handful of+-- type variables, which select precise varint behaviour beyond this. See their+-- documentation for details.+--+-- You may select the type to use varnats at, but error handling isn't provided:+-- negatives won't work correctly, and overflow cannot be detected. So most of+-- the time, you probably want 'Natural' and 'Integer'.+--+-- Some examples:+--+--   * @'Varnat' ''Redundant' ''OnContinues'  ''BE' matches VLQ.+--   * @'Varnat' ''Redundant' ''OnContinues'  ''LE' matches LEB128, protobuf.+--   * @'Varnat' ''Bijective' ''OnContinues'  ''LE' matches Git's varints.+--   * @'Varnat' ''Bijective' ''OffContinues' ''LE' matches BPS's varints.+newtype Varnat (enc :: Encoding) (cont :: ContinuationBitBehaviour) (e :: Endianness) i = Varnat { getVarnat :: i }+    deriving (Eq, Ord, Enum, Num, Real, Integral) via i+    deriving stock Show++data ContinuationBitBehaviour+  = OnContinues+  -- ^ on=continue, off=end++  | OffContinues+  -- ^ on=end, off=continue++data Encoding+  = Redundant+  -- ^ simple, some varints have the same value++  | Bijective+  -- ^ each integer has exactly 1 varint encoding++-- | VLQ (cont=on)+instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'BE i) where+    get = go (0 :: i)+      where+        go i = do+            w8 <- FP.anyWord8+            let i' = unsafeShiftL i 7 .|. fromIntegral (clearBit w8 7)+            if testVarintCont @cont w8 7 then go i' else pure (Varnat i')++-- | TODO nothing to test against - unsure if correct+instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'BE i) where+    get = go (0 :: i)+      where+        go i = do+            w8 <- FP.anyWord8+            let i' = unsafeShiftL i 7 .|. (fromIntegral (clearBit w8 7) + 1)+            if testVarintCont @cont w8 7 then go i' else pure (Varnat (i'-1))++-- | protobuf (cont=on), LEB128 (cont=on)+--+-- not truly infinite length since shifters take 'Int', but practically infinite+instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'LE i) where+    get = go (0 :: i) (0 :: Int)+      where+        go i n = do+            w8 <- FP.anyWord8+            let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7)) n+            if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat i')++-- | Git varint (cont=on), BPS (beat patches) (cont=off)+instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'LE i) where+    get = go (0 :: i) (0 :: Int)+      where+        go i n = do+            w8 <- FP.anyWord8+            let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7) + 1) n+            if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat (i'-1))++-- TODO uses fromIntegral's overflow behaviour+instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'LE i) where+    put (Varnat i) = do+        if i < 0b10000000 then+            put @Word8 $ fromIntegral i+        else+               put @Word8 (setVarintCont @cont (fromIntegral i) 7)+            <> put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7))++-- TODO BE. Hard.+instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'BE i) where+    put (Varnat i) = do+        if i < 0b10000000 then+            put @Word8 $ fromIntegral i+        else+               put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7))+            <> put @Word8 (setVarintCont @cont (fromIntegral (i .&. 0b11111111)) 7)++--------------------------------------------------------------------------------++class VarintContinuation (cont :: ContinuationBitBehaviour) where+    varintContinue :: Bool+instance VarintContinuation 'OnContinues  where varintContinue = True+instance VarintContinuation 'OffContinues where varintContinue = False++testVarintCont+    :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> Bool+testVarintCont a n = case varintContinue @cont of True  -> b+                                                  False -> not b+  where b = testBit a n++setVarintCont+    :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> a+setVarintCont = case varintContinue @cont of True  -> setBit+                                             False -> clearBit

@@ -11,9 +11,8 @@ import Data.Vector.Sized ( Vector ) import GHC.TypeNats -type instance CBLen (Vector n a) = CBLen a * n- instance BLen a => BLen (Vector n a) where+    type CBLen (Vector n a) = CBLen a * n     blen = V.sum . V.map blen  instance Put a => Put (Vector n a) where

@@ -0,0 +1,46 @@+module Haskpatch.Format.Bps where++import Binrep.Type.Magic+import Binrep.Type.Sized+import Binrep.Type.Varint+import Binrep.Type.Common+import Strongweak++import Data.ByteString qualified as B++-- | TODO+--   * can't do generic because BPS doesn't store command list length, instead+--     requiring a dynamic check on every command+--     * wonder if this is better or more efficient that using a 'BpsVarint' for+--       the length, same as metadata, or storing the end size as a 'BpsVarint'.+--   * maybe two diff types of varint, +ve and -ve. unclear from spec+--   * perhaps store the varint type(s) as a type var, to allow switching+--     between efficient machine ints and safe 'Integer', 'Natural'!+data Bps (s :: Strength) i a = Bps+  { bpsMagic :: SW s (Magic "BPS1")+  , bpsSourceSize :: SW s (BpsVarint i)+  , bpsTargetSize :: SW s (BpsVarint i)++  , bpsMetadata :: BpsMeta a+  -- ^ Optional metadata. According to the specification, this should+  --   "officially" be XML version 1.0 encoding UTF-8 data, but anything goes.++  , bpsCommands :: [BpsCommand]+  , bpsFooter :: BpsFooter s+  }++type BpsVarint = Varnat 'Bijective 'OffContinues 'LE++data BpsMeta a++data BpsCommand+  = BpsCommandSourceRead+  | BpsCommandTargetRead+  | BpsCommandSourceCopy+  | BpsCommandTargetCopy++data BpsFooter (s :: Strength) = BpsFooter+  { bpsFooterSourceChecksum :: SW s (Sized 4 B.ByteString)+  , bpsFooterTargetChecksum :: SW s (Sized 4 B.ByteString)+  , bpsFooterPatchChecksum  :: SW s (Sized 4 B.ByteString)+  }

@@ -0,0 +1,57 @@+-- | https://datatracker.ietf.org/doc/html/rfc3284++module Haskpatch.Format.Vcdiff where++import Binrep.Type.Magic+import Binrep.Type.Varint+import Binrep.Type.Common+import Strongweak++import Numeric.Natural+import Data.ByteString ( ByteString )+import Data.Word ( Word8 )++data Vcdiff (s :: Strength) = Vcdiff+  { vcdiffHeader :: Header s+  }++data Header (s :: Strength) = Header+  { headerMagic :: SW s (Magic '[0xD6, 0xC3, 0xC4, 0x00])+  -- ^ First 3 bytes are @VCD@ each with their MSB on.++  , headerIndicator :: SW s (Magic '[0x00])+  -- ^ TODO annoying and impacts rest of format. forcing to 0x00 to simplify+  }++data Window (s :: Strength) = Window+  { windowIndicator :: SW s (Magic '[0x00]) -- TODO+  , windowDelta :: Delta s+  }++data Delta (s :: Strength) = Delta+  { deltaIndicator :: SW s (Magic '[0x00]) -- TODO compression indicators. ignoring+  , deltaAddRun :: ByteString+  , deltaInstrs :: [InstrCode]+  , deltaCopy   :: ByteString+  }++data InstrCode = InstrCode+  { instrCodeTriple1 :: InstrTriple+  , instrCodeTriple2 :: InstrTriple+  }++data InstrTriple = InstrTriple+  { instrTripleInstr :: Instr++  , instrTripleSize  :: Word8++  , instrTripleMode  :: Word8+  -- ^ 0 and meaningless unless instr is a COPY+  }++-- TODO singletons it+data Instr = Instr0Noop | Instr1Add | Instr2Run | Instr3Copy++-- | Apparently from the Sfio library, also similar (but not identical) to BPS's+--   varints.+type VcdiffVarint = Varnat 'Redundant 'OnContinues 'BE Natural

@@ -0,0 +1,29 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Util.Generic where++import GHC.Generics++-- | 'datatypeName' without the value (only used as a proxy). Lets us push our+--   'undefined's into one place.+datatypeName' :: forall d. Datatype d => String+datatypeName' = datatypeName @d undefined++-- | 'conName' without the value (only used as a proxy). Lets us push our+--   'undefined's into one place.+conName' :: forall c. Constructor c => String+conName' = conName @c undefined++-- | 'selName' without the value (only used as a proxy). Lets us push our+--   'undefined's into one place.+selName' :: forall s. Selector s => String+selName' = selName @s undefined++-- | Get the record name for a selector if present.+--+-- On the type level, a 'Maybe Symbol' is stored for record names. But the+-- reification is done using @fromMaybe ""@. So we have to inspect the resulting+-- string to determine whether the field uses record syntax or not. (Silly.)+selName'' :: forall s. Selector s => Maybe String+selName'' = case selName' @s of "" -> Nothing+                                s  -> Just s

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Binrep.LawsSpec ( spec ) where+module Binrep.LawsSpec where  import Test.Hspec import Test.Hspec.QuickCheck@@ -18,6 +18,8 @@ import Data.ByteString qualified as B import GHC.Generics ( Generic ) +import Control.Exception ( evaluate )+ spec :: Spec spec = do     prop "put is identity on ByteString" $ do@@ -26,6 +28,15 @@       \(bs :: B.ByteString) -> runGet (runPut bs) `shouldBe` Right (bs, "")     prop "parse-print roundtrip isomorphism (generic, sum tag via nullterm constructor)" $ do       \(d :: D) -> runGet (runPut d) `shouldBe` Right (d, "")+    prop "serializing a type with an incorrect generic derivation throws an exception" $ do+      \(d :: DNoSum) -> do+        let evaluateShouldThrow a = evaluate a `shouldThrow` (\case EDerivedSumInstanceWithNonSumCfg -> True)+        evaluateShouldThrow (blen d)+        evaluateShouldThrow (runPut d)+    prop "parsing a type with an incorrect generic derivation fails" $ do+      \(bs :: B.ByteString) -> do+        let e = EGeneric "DNoSum" $ EGenericSum $ EGenericSumTag $ EBase ENoVoid+        runGet @DNoSum bs `shouldBe` Left e  -------------------------------------------------------------------------------- @@ -42,8 +53,17 @@ deriving via (GenericArbitraryU `AndShrinking` D) instance Arbitrary D  dCfg :: Cfg (AsByteString 'C)-dCfg = Cfg { cSumTag = cSumTagNullTerm }+dCfg = cfg cSumTagNullTerm  instance BLen D where blen = blenGeneric dCfg instance Put  D where put  = putGeneric  dCfg instance Get  D where get  = getGeneric  dCfg++data DNoSum = DNoSum Word8 W1 W2LE W8BE+  | DNoSumBad+    deriving stock (Generic, Eq, Show)+deriving via (GenericArbitraryU `AndShrinking` DNoSum) instance Arbitrary DNoSum++instance BLen DNoSum where blen = blenGeneric cNoSum+instance Put  DNoSum where put  = putGeneric  cNoSum+instance Get  DNoSum where get  = getGeneric  cNoSum