diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## 0.2.0 (2022-07-07) +Multiple rewrites (unable to push to Hackage for a while due to dependencies). + + * BinaryCodec split into Get and Put + * fast serializing via fumieval's mason + * fast parsing via András Kovács' flatparse + * integration with my strongweak library + * generics + * tests + * CBLen for constant length types + * plenty more + ## 0.1.0 (2022-04-22) Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,135 @@ +[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 + # binrep -Haskell data types with their binary representation explicitly built into the -types. Intended for simple binary file parsing. +binrep is a library for **precisely modelling binary schemas** and working with +them effectively and efficiently in Haskell. Here's why it's useful: -The binary and cereal libraries are for passing Haskell data between other -binary and cereal users. Thus, data representation is largely obscured. For -example, in `cereal`, all data is handled in big-endian format. If you use the -`Serialize` typeclass methods for parsing and serializing, you would never know. + * **Explicit:** Binary representation primitives such as C-style bytestrings + (null-terminated), sized explicit-endian machine integers, and null-padded + data enable defining Haskell data types with the binary schema "baked in". + * **Low boilerplate:** Generic parsers and serializers further reduce boilerplate for + straightforward schemas. (See [Generic binary + representation](#generic-binary-representation) for details.) + * **Easy validation:** Goes hand in hand with my [strongweak][gh-strongweak] + library to allow working with unwrapped data internally, and enforcing all + the binary representation invariants before serializing - no extra + definitions required. + * **Performant:** Parsing and serialization is low-level and *extremely fast*, + using [flatparse][gh-flatparse] and [mason][gh-mason] respectively. -binrep never makes decisions by itself. You can't parse/serialize a `Word64` -without either providing the endianness to use at runtime, or encoding the -endianness into the type. +## Philosophy +### Modelling, not serializing +binrep is good at modelling binary data formats. It is not a plain +"serialization" library, where the actual binary representation is hidden from +the user (intentionally, with good reason). The binary and cereal libraries are +great choices for that. They are interested in defining efficient binary codecs +for Haskell data. However, their codec typeclasses *hide representation +decisions* from the user. In cereal, -See the Hackage documentation for details. + * machine integers are encoded with + [big endian](https://hackage.haskell.org/package/cereal-0.5.8.2/docs/src/Data.Serialize.html#line-182) + * bytestrings are written with an + [8-byte length prefix](https://hackage.haskell.org/package/cereal-0.5.8.2/docs/src/Data.Serialize.html#line-498) + +These are fine decisions. But they aren't accurate to the types. Endianness is +an implementation decision. + +binrep refuses to work with a machine integer unless it knows the endianness. +Bytestrings are split into C-style (null-terminated) and Pascal-style +(length-prefixed). This enforces careful consideration for the binary data being +modelled. + +### Validation without boilerplate +A C-style bytestring must not contain any `0x00` null bytes. A Pascal-style +bytestring must be short enough to be able to encode its length in the length +prefix machine integer. But checking such invariants is tedious work. Am I +really going to wrap everything in a bunch of newtypes and force users to call a +bunch of checker functions every time? + +Yes and no. Yes, binrep uses newtypes extensively, though most are type synonyms +over the `Refined` newtype from Nikita Volkov's wonderful [refined][gh-refined] +library. No, binrep doesn't want you to wrangle with these day-to-day. One +solution is to define a simplified "weak" type, and convert between it and the +binary-safe "strong" type. My [strongweak][gh-strongweak] library provides +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 +binrep's generic deriving makes very few decisions: + + * Constructors are encoded by sequentially encoding every enclosed field. + * Empty constructors thus serialize to 0 bytes. + * Sum types are encoded via a tag obtained from the constructor names. + * It's the same approach as aeson, with a bit more flexibility: see below. + +Sum types (data types with multiple constructors) are handled by first encoding +a "tag field", the value of which then indicates which constructor to use. You +must provide a function to convert from a constructor name to a (unique) tag. +You could encode them as a null-terminated ASCII bytestring (this is the +default), or as a single byte. To ease this, you may consider putting the tag +value in constructor names: + +```haskell +data BinarySumType = B1 | B2 + +getConstructorTag :: String -> Word8 +getConstructorTag = read . drop 1 + +-- >>> getConstructorTag "B1" +-- 1 + +-- Or use our generic helper, which takes hex values: +-- +-- >>> cSumTagHex @Word8 (drop . 1) "BFF" +-- 255 +``` + +## Similar projects +### Kaitai Struct +[Kaitai Struct](https://kaitai.io/) is a wonderful declarative parser generator +project. They bolt an expression language and a whole lot of binary cleverness +on top of a nice YAML schema. It comes with an IDE, a visualizer, and you can +compile schemas down to parsers for various different languages (no Haskell...). + +Design principles like their fancy absolute offset handling and language +neutrality have stunted serialization support. Though it's more like they have +such powerful parsing that they can parse formats that can't be edited and +re-serialized naively, like archives with file indexes. For proper handling, one +should store a file table, and serialization generates the index. So in reverse, +you would want to combine them. But it's a bit program-y. In binrep, you are in +a programming language, so it's less of a problem... but I'm not sure if we can +be very efficient at absolute offset stuff. + +Realistically, Kaitai Struct is the best decision for fast iteration on +reversing unknown data. binrep is useful for loading data straight into Haskell +for further processing, especially converting between simpler formats. + +### Wuffs +[Wuffs](https://github.com/google/wuffs) is a crazy exploration into safe +low-level code via strong typing. You have to annotate every possibly dangerous +statement with a proof of safety. It's a tedious, explicit, very safe and very +fast imperative language for defining parsers and serializers. + +Wuffs is more a codec engineer's tool than a reverse engineer's one. binrep +isn't really interested in speed, and being a Haskell library we get to focus on +defining types and their composition in a declarative & functional manner. As +such, we get to define more useful things quicker using binrep. Though we share +many core ideas, such as refinement types. + +Check out Wuffs if you need to write a bunch of codecs and they really, really +need to be both fast and safe. The trade-off is, of course, your time. diff --git a/binrep.cabal b/binrep.cabal --- a/binrep.cabal +++ b/binrep.cabal @@ -5,10 +5,10 @@ -- see: https://github.com/sol/hpack name: binrep -version: 0.1.0 -synopsis: Encode binary representations via types. +version: 0.2.0 +synopsis: Encode precise binary representations directly in types description: Please see README.md. -category: Data +category: Data, Serialization homepage: https://github.com/raehik/binrep#readme bug-reports: https://github.com/raehik/binrep/issues author: Ben Orchard @@ -17,7 +17,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC ==8.10.7 || ==9.2.2 + GHC ==9.2.2 extra-source-files: README.md CHANGELOG.md @@ -28,25 +28,50 @@ library exposed-modules: - Binrep.ByteLen - Binrep.Codec - Binrep.Predicates.NullPadTo - Binrep.Types.Ints - Binrep.Types.Strings + Binrep + Binrep.BLen + Binrep.BLen.Internal.AsBLen + Binrep.CBLen + Binrep.Example + Binrep.Example.FileTable + Binrep.Example.Tar + Binrep.Example.Tiff + Binrep.Example.Wav + Binrep.Extra.HexByteString + Binrep.Generic + Binrep.Generic.BLen + Binrep.Generic.CBLen + Binrep.Generic.Get + Binrep.Generic.Internal + Binrep.Generic.Put + Binrep.Get + Binrep.Put + Binrep.Type.AsciiNat + Binrep.Type.Byte + Binrep.Type.ByteString + Binrep.Type.Common + Binrep.Type.Int + Binrep.Type.LenPfx + Binrep.Type.Magic + Binrep.Type.Magic.UTF8 + Binrep.Type.NullPadded + Binrep.Type.Sized + Binrep.Type.Text + Binrep.Type.Vector Binrep.Util + Data.Aeson.Extra.SizedVector other-modules: Paths_binrep hs-source-dirs: src default-extensions: EmptyCase - FlexibleContexts - FlexibleInstances - InstanceSigs - MultiParamTypeClasses - PolyKinds LambdaCase + InstanceSigs + BangPatterns + ExplicitNamespaces DerivingStrategies + DerivingVia StandaloneDeriving DeriveAnyClass DeriveGeneric @@ -55,27 +80,101 @@ DeriveFoldable DeriveTraversable DeriveLift - ImportQualifiedPost - StandaloneKindSignatures - DerivingVia + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + GADTs + PolyKinds RoleAnnotations + RankNTypes TypeApplications - DataKinds + DefaultSignatures TypeFamilies + DataKinds + MagicHash + ImportQualifiedPost + StandaloneKindSignatures + ScopedTypeVariables TypeOperators + ghc-options: -Wall + build-depends: + aeson ==2.0.* + , base >=4.14 && <5 + , bytestring ==0.11.* + , either >=5.0.1.1 && <5.1 + , flatparse >=0.3.5.0 && <0.4 + , mason >=0.2.5 && <0.3 + , 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 + , vector >=0.12.3.1 && <0.13 + , vector-sized >=1.5.0 && <1.6 + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ArbitraryOrphans + Binrep.Extra.HexByteStringSpec + Binrep.LawsSpec + Paths_binrep + hs-source-dirs: + test + default-extensions: + EmptyCase + LambdaCase + InstanceSigs BangPatterns + ExplicitNamespaces + DerivingStrategies + DerivingVia + StandaloneDeriving + DeriveAnyClass + DeriveGeneric + DeriveDataTypeable + DeriveFunctor + DeriveFoldable + DeriveTraversable + DeriveLift + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses GADTs - DefaultSignatures + PolyKinds + RoleAnnotations RankNTypes - UndecidableInstances + TypeApplications + DefaultSignatures + TypeFamilies + DataKinds MagicHash + ImportQualifiedPost + StandaloneKindSignatures ScopedTypeVariables + TypeOperators + ghc-options: -Wall + build-tool-depends: + hspec-discover:hspec-discover >=2.7 && <2.10 build-depends: - aeson ==2.0.* + QuickCheck >=2.14.2 && <2.15 + , aeson ==2.0.* , base >=4.14 && <5 + , binrep , bytestring ==0.11.* - , cereal >=0.5.8.1 && <0.6 - , refined >=0.6.3 && <0.7 - , refined-with >=0.1.0 && <0.2 + , either >=5.0.1.1 && <5.1 + , flatparse >=0.3.5.0 && <0.4 + , generic-random >=1.5.0.1 && <1.6 + , hspec >=2.7 && <2.10 + , mason >=0.2.5 && <0.3 + , megaparsec >=9.2.0 && <9.3 + , 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 + , vector >=0.12.3.1 && <0.13 + , vector-sized >=1.5.0 && <1.6 default-language: Haskell2010 diff --git a/src/Binrep.hs b/src/Binrep.hs new file mode 100644 --- /dev/null +++ b/src/Binrep.hs @@ -0,0 +1,16 @@ +{- | Helper module to bring most functionality into scope. + +Generics are in a separate module (to prevent module import cycles). +-} + +module Binrep + ( module Binrep.BLen + , module Binrep.CBLen + , module Binrep.Put + , module Binrep.Get + ) where + +import Binrep.BLen +import Binrep.CBLen +import Binrep.Put +import Binrep.Get diff --git a/src/Binrep/BLen.hs b/src/Binrep/BLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/BLen.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Binrep.BLen + ( module Binrep.BLen + , module Binrep.BLen.Internal.AsBLen + ) where + +import Binrep.BLen.Internal.AsBLen +import Binrep.CBLen +import Binrep.Util ( natVal'' ) + +import GHC.TypeNats +import Data.ByteString qualified as B +import Data.Word +import Data.Int + +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. +class BLen a where + blen :: a -> BLenT + default blen :: KnownNat (CBLen a) => a -> BLenT + blen _ = cblen @a + +typeNatToBLen :: forall n. KnownNat n => BLenT +typeNatToBLen = natToBLen $ natVal'' @n +{-# INLINE typeNatToBLen #-} + +-- | Reify a type's constant byte length to the term level. +cblen :: forall a n. (n ~ CBLen a, KnownNat n) => BLenT +cblen = typeNatToBLen @n +{-# INLINE cblen #-} + +-- | @O(n)@ +instance BLen a => BLen [a] where + blen = sum . map blen + +instance (BLen a, BLen b) => BLen (a, b) where + blen (a, b) = blen a + blen b + +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 diff --git a/src/Binrep/BLen/Internal/AsBLen.hs b/src/Binrep/BLen/Internal/AsBLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/BLen/Internal/AsBLen.hs @@ -0,0 +1,65 @@ +module Binrep.BLen.Internal.AsBLen where + +import GHC.Natural ( minusNaturalMaybe ) +import GHC.Num.Natural +import GHC.Exts +import Binrep.Util ( posIntToNat ) + +-- | Helper definitions for using the given type to store byte lengths. +-- +-- Byte lengths must be non-negative. Thus, the ideal representation is a +-- 'Natural'. However, most underlying types that we use ('B.ByteString', lists) +-- store their length in 'Int's. By similarly storing an 'Int' ourselves, we +-- could potentially improve performance. +-- +-- I like both options, and don't want to give up either. So we provide helpers +-- via a typeclass so that the user doesn't ever have to think about the +-- underlying type. +-- +-- For simplicity, documentation may consider 'a' to be an "unsigned" type. For +-- example, underflow refers to a negative 'a' result. +class AsBLen a where + -- | Safe blen subtraction, returning 'Nothing' for negative results. + -- + -- Regular subtraction should only be used when you have a guarantee that it + -- won't underflow. + safeBLenSub :: a -> a -> Maybe a + + -- | Convert some 'Int' @i@ where @i >= 0@ to a blen. + -- + -- This is intended for wrapping the output of 'length' functions. + posIntToBLen :: Int -> a + + -- | Convert some 'Word#' @w@ where @w <= maxBound @a@ to a blen. + wordToBLen# :: Word# -> a + + -- | Convert some 'Natural' @n@ where @n <= maxBound @a@ to a blen. + natToBLen :: Natural -> a + +instance AsBLen Int where + safeBLenSub x y = if z >= 0 then Just z else Nothing where z = x - y + {-# INLINE safeBLenSub #-} + + posIntToBLen = id + {-# INLINE posIntToBLen #-} + + natToBLen = \case + NS w# -> wordToBLen# w# + NB _ -> error "TODO natural too large" + {-# INLINE natToBLen #-} + + wordToBLen# w# = I# (word2Int# w#) + {-# INLINE wordToBLen# #-} + +instance AsBLen Natural where + safeBLenSub = minusNaturalMaybe + {-# INLINE safeBLenSub #-} + + posIntToBLen = posIntToNat + {-# INLINE posIntToBLen #-} + + wordToBLen# = NS + {-# INLINE wordToBLen# #-} + + natToBLen = id + {-# INLINE natToBLen #-} diff --git a/src/Binrep/ByteLen.hs b/src/Binrep/ByteLen.hs deleted file mode 100644 --- a/src/Binrep/ByteLen.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- TODO -Potentially should be moved into BinaryCodec. We need this for padding-based -combinators. Each inside combinator must report the number of bytes they -serialized. It *should* be extremely cheap. - -So far I haven't got another use for it, and I feel there should be some better -way to define it but the types don't fit well. So I'll leave it as is for now. --} - -module Binrep.ByteLen where - -import Numeric.Natural - --- | The size in bytes of the type can be known, preferably on the cheap e.g. --- reading a length field. --- --- Aim to make this O(1). Except for where you can't like lists lol. --- --- Importantly goes hand in hand with BinaryCodec! Maybe we should make it a --- function there lol! --- --- This is useful for padding types generically, without having to track the --- read/write cursor. Yes, that feature *is* common and cheap for parsers (and --- to lesser extent, serializers), but you should really only be padding types --- that have a "static-ish" (= cheaply calculated) size. At least, I think so? --- I'm not quite sure. --- --- Some instances ignore the argument. It would be possible to pull those out --- into a statically-known bytelength typeclass, but it wouldn't improve clarity --- or performance, just get rid of a couple 'undefined's. -class ByteLen a where - blen :: a -> Natural - -instance ByteLen a => ByteLen [a] where blen = sum . map blen diff --git a/src/Binrep/CBLen.hs b/src/Binrep/CBLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/CBLen.hs @@ -0,0 +1,21 @@ +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 diff --git a/src/Binrep/Codec.hs b/src/Binrep/Codec.hs deleted file mode 100644 --- a/src/Binrep/Codec.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Binrep.Codec where - -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BL -import Data.ByteString.Builder qualified as B -import Data.Serialize - --- | Types that can be coded precisely between binary and a Haskell type. --- --- This class looks identical to cereal's 'Serialize', but we take a different --- approach to instances. --- --- 'Data.Serialize.Serialize' defines an internal binary codec for common --- Haskell types. It makes implicit decisions, such as big-endian for all --- integer types, and coding lists with a (big-endian) 'Word64' length prefix. --- It only works with other data serialized with the same library. --- --- This typeclass defines composable binary codec combinators. If you want to --- write a codec for a 'Word64', it needs to specify its endianness in the type. --- If you want to write a codec for a list with a 'Word8' length prefix, it must --- come with a proof that it's not oversized. --- --- The idea is to use this typeclass along with various annotated newtypes to --- allow defining a Haskell type's binary representation directly in the types. --- In cases where you're doing intermediate serialization and not much else, it --- may be convenient. You will need to do a bunch of (free at runtime) wrapping --- though. -class BinaryCodec a where - toBin :: Putter a -- ^ Encode to binary. Same as cereal's 'put'. - fromBin :: Get a -- ^ Decode from binary. Same as cereal's 'get'. - --- | Run the encoder for a supporting type. -binEncode :: BinaryCodec a => a -> BS.ByteString -binEncode = runPut . toBin - --- | Run the decoder a supporting type. -binDecode :: BinaryCodec a => BS.ByteString -> Either String a -binDecode = runGet fromBin - --- | Serialize each element in order. No length indicator, so parse until either --- error or EOF. Usually not what you want, but sometimes used at the "top" of --- binary formats. -instance BinaryCodec a => BinaryCodec [a] where - toBin as = mapM_ toBin as - fromBin = go [] - where - go as = do - a <- fromBin - isEmpty >>= \case - True -> return $ reverse $ a : as - False -> go $ a : as - --- | Types that can be coded between binary and a Haskell type given some --- runtime information. --- --- We can't prove something related to a value and pass that proof along without --- dependent types, meaning we can't split validation from encoding like in --- 'BinaryCodec', so encoding can fail. However, by allowing an arbitrary --- environment, we can define many more convenient instances. --- --- For example, you can't write a 'BinaryCodec' instance for 'Word16' because it --- doesn't specify its endianness. But you can define 'BinaryCodecWith --- Endianness Word16'! This was, you can decide how much of the binary schema --- you want to place directly in the types, and how much to configure --- dynamically. --- --- This class defaults to the free implementation provided by 'BinaryCodec', --- which ignores the environment and wraps serializing with 'Right'. -class BinaryCodecWith r a where - -- | Encode to binary with the given environment. - toBinWith :: r -> a -> Either String B.Builder - default toBinWith :: BinaryCodec a => r -> a -> Either String B.Builder - toBinWith = const $ Right . execPut . toBin - - -- | Decode to binary with the given environment. - fromBinWith :: r -> Get a - default fromBinWith :: BinaryCodec a => r -> Get a - fromBinWith = const fromBin - --- | Run the encoder for a supporting type using the given environment. -binEncodeWith :: BinaryCodecWith r a => r -> a -> Either String BS.ByteString -binEncodeWith r a = BL.toStrict . B.toLazyByteString <$> toBinWith r a - --- | Run the decoder for a supporting type using the given environment. -binDecodeWith :: BinaryCodecWith r a => r -> BS.ByteString -> Either String a -binDecodeWith = runGet . fromBinWith diff --git a/src/Binrep/Example.hs b/src/Binrep/Example.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Binrep.Example where + +import Binrep +import Binrep.Generic +import Binrep.Generic qualified as BR +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.Int + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +brCfgNoSum :: BR.Cfg (I 'U 'I1 'LE) +brCfgNoSum = BR.Cfg { BR.cSumTag = undefined } + +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 +-} + +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 + +data DSS = DSS + { dss1 :: I 'U 'I1 'LE + , dss2 :: I 'U 'I2 'LE + , dss3 :: I 'U 'I4 'LE + , dss4 :: I 'U 'I8 'LE + , 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 + +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 } + +--instance BR.BLen DCS where blen = BR.blenGeneric brCfgDCS +deriving anyclass instance BLen 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) diff --git a/src/Binrep/Example/FileTable.hs b/src/Binrep/Example/FileTable.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/FileTable.hs @@ -0,0 +1,105 @@ +module Binrep.Example.FileTable where + +import Binrep +import Refined hiding ( Weaken ) +import Refined.Unsafe +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.Int +import Binrep.Type.LenPfx +import FlatParse.Basic qualified as FP +import Data.ByteString qualified as B +import Strongweak +import Strongweak.Generic +--import Data.Map ( Map ) +import GHC.Generics ( Generic ) +import GHC.Exts +import Data.Vector.Sized qualified as V +import Data.Word + +type BS = B.ByteString + +-- We're unable to put one invariant in the types: an entry can't be placed past +-- the maximum offset. Validating that requires quite a lot of work: we have to +-- do much of the layouting work, which will be repeated for serializing. This +-- is a downside of phase separation, it crops up every now and then. +-- +-- The BLen instance will similarly be a bit complex, but it could probably be +-- implemented with similar code to strengthening. +newtype Table s a = Table { unTable :: SW s (LenPfx 'I1 'LE (Entry s a)) } + +instance (Put a, BLen a) => Put (Table 'Strong a) where put = putFileTable + +putFileTable :: (Put a, BLen a) => Table 'Strong a -> Builder +putFileTable (Table a@(LenPfx es)) = + let es' = V.map prepEntry es + osBase = V.sum $ V.map (\(l, _, _) -> l) es' + in case V.foldl go ((fromIntegral osBase) - 1, mempty, mempty) es' of + (_, bh, bd) -> put (lenPfxSize a) <> bh <> bd + where + go :: (Word8, Builder, Builder) -> (BLenT, Word8 -> Builder, BS) -> (Word8, Builder, Builder) + go (os, bh, bd) (_, eh, ed) = (os+fromIntegral (B.length ed), bh<>eh os, bd<>put ed) + +prepEntry :: (Put a, BLen a) => Entry 'Strong a -> (BLenT, Word8 -> Builder, BS) +prepEntry (Entry nm bs) = (l, b, bs') + where + bs' = unrefine bs + b os = + put nm <> put os <> put (fromIntegral (B.length bs') :: Word8) + l = blen nm + 1 + 1 + blen bs' + +instance Get a => Get (Table 'Strong a) where get = getFileTable + +getFileTable :: Get a => Getter (Table 'Strong a) +getFileTable = FP.withAddr# $ \addr# -> Table <$> getLenPfx (getWith addr#) + +{- +This is certainly a weird type. + + * Can use regular strongweak generics + * Has no 'Get' instance + * Has a 'GetWith Addr#' instance + * Has no 'Put' instance + * Has no 'PutWith' instance + +You can't serialize an 'Entry' by itself, because it serializes to two +artifacts, a header entry and the associated data. Now I see why Kaitai Struct +was having trouble with serializing this sort of type. +-} +data Entry s a = Entry + { entryName :: a + , entryData :: SW s (Refined (SizeLessThan (IMax 'U 'I1)) BS) + } deriving stock (Generic) +deriving stock instance Show a => Show (Entry 'Weak a) +deriving stock instance Eq a => Eq (Entry 'Weak a) +deriving stock instance Show a => Show (Entry 'Strong a) +deriving stock instance Eq a => Eq (Entry 'Strong a) +instance Weaken (Entry 'Strong a) where + type Weak (Entry 'Strong a) = Entry 'Weak a + weaken = weakenGeneric +instance Strengthen (Entry 'Strong a) where + strengthen = strengthenGeneric + +instance Get a => GetWith Addr# (Entry 'Strong a) where getWith = getEntry + +getEntry :: Get a => Addr# -> Getter (Entry 'Strong a) +getEntry addr# = do + name <- get + dat <- FP.withAnyWord8# $ \offset# -> FP.withAnyWord8# $ \len# -> + FP.takeBsOffAddr# addr# (w8i# offset#) (w8i# len#) + return $ Entry name (reallyUnsafeRefine dat) + +w8i# :: Word8# -> Int# +w8i# w# = word2Int# (word8ToWord# w#) + +exBs :: BS +exBs = B.pack + [ 0x02 + , 0x30, 0x31, 0x32, 0x00 + , 12 -- <- offset!! + , 0x01 + , 0x39, 0x38, 0x00 + , 13 + , 0x01 + , 0xFF + , 0xF0 + ] diff --git a/src/Binrep/Example/Tar.hs b/src/Binrep/Example/Tar.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/Tar.hs @@ -0,0 +1,67 @@ +module Binrep.Example.Tar where + +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 + +import GHC.Generics ( Generic ) + +import Data.Word ( Word8 ) + +import GHC.TypeNats + +import Data.ByteString qualified as B + +import FlatParse.Basic qualified as FP + +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. +-- +-- Don't use this constructor directly! The size must be checked to ensure it +-- fits. +newtype TarNat n = TarNat { getTarNat :: AsciiNat 8 } + deriving stock (Generic, Show, Eq) + +type instance CBLen (TarNat n) = n +instance KnownNat n => BLen (TarNat n) + +-- | No need to check for underflow etc. as TarNat guarantees good sizing. +instance KnownNat n => Put (TarNat n) where + put (TarNat an) = put pfxNulls <> put an <> put @Word8 0x00 + where + pfxNulls = B.replicate (fromIntegral pfxNullCount) 0x30 + pfxNullCount = n - blen an - 1 + n = typeNatToBLen @n + +instance KnownNat n => Get (TarNat n) where + get = do + an <- FP.isolate (fromIntegral (n - 1)) get + get @Word8 >>= \case + 0x00 -> return $ TarNat an + w -> FP.err $ "TODO expected null byte, got " <> show w + where + n = typeNatToBLen @n + +-- Partial header +data Tar = Tar + { tarFileName :: NullPadded 100 BS + , tarFileMode :: TarNat 8 + , tarFileUIDOwner :: TarNat 8 + , tarFileUIDGroup :: TarNat 8 + , tarFileFileSize :: TarNat 12 + , 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 diff --git a/src/Binrep/Example/Tiff.hs b/src/Binrep/Example/Tiff.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/Tiff.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Binrep.Example.Tiff where + +import Binrep +import Binrep.Generic +import Binrep.Generic qualified as BR +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.Int +import Binrep.Type.Magic +import Binrep.Type.Byte +import FlatParse.Basic ( (<|>) ) + +import GHC.Generics ( Generic ) +import Data.Data ( Data, Typeable ) +import GHC.TypeLits + +import Data.ByteString qualified as B + +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 + +instance Show Tiff where + show (Tiff body) = "Tiff " <> show body + +data TiffBody (end :: Endianness) = TiffBody + { tiffBodyMagic :: Magic (TiffMagic end) + , tiffBodyExInt :: I 'U 'I4 end + } 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 BLen Tiff where + blen (Tiff body) = blen body + +instance Put Tiff where + put (Tiff body) = put body + +instance Get Tiff where + get = fmap Tiff (get @(TiffBody 'LE)) <|> fmap Tiff (get @(TiffBody 'BE)) + +type family TiffMagic (end :: Endianness) :: Symbol where + TiffMagic 'LE = "II" + TiffMagic 'BE = "MM" + +tiffLEbs :: B.ByteString +tiffLEbs = B.pack [0x49, 0x49, 0xFF, 0x00, 0x00, 0x00] + +tiffBEbs :: B.ByteString +tiffBEbs = B.pack [0x4D, 0x4D, 0x00, 0x00, 0x00, 0xFF] diff --git a/src/Binrep/Example/Wav.hs b/src/Binrep/Example/Wav.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/Wav.hs @@ -0,0 +1,31 @@ +module Binrep.Example.Wav where + +import Binrep +import Binrep.Generic +import Binrep.Generic qualified as BR +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.Int +import Binrep.Type.Magic + +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 } + +data WavHeader = WavHeader + { wavHeaderMagic :: Magic "RIFF" + , wavHeaderChunkSize :: W32 -- file size - 8 + , wavHeaderFmt :: Magic "WAVE" + , wavHeaderFmtChunkMarker :: Magic "fmt " + , wavHeaderFmtType :: W16 + , 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 diff --git a/src/Binrep/Extra/HexByteString.hs b/src/Binrep/Extra/HexByteString.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Extra/HexByteString.hs @@ -0,0 +1,109 @@ +-- | Pretty bytestrings via printing each byte as two hex digits. +-- +-- This is primarily for aeson and when we want better 'show'ing of non-textual +-- bytestrings. It's not really binrep-related, but it needs _somewhere_ to go +-- and my projects that need it usually also touch binrep, so here it is. +-- +-- Sadly, we can't use it to make aeson print integers as hex literals. It only +-- deals in Scientifics, and if we tried printing them as strings, it would +-- quote them. I need a YAML-like with better literals... + +module Binrep.Extra.HexByteString where + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +import Data.ByteString qualified as B +import Data.ByteString.Short qualified as B.Short +import Data.Char qualified as Char +import Data.Word +import Data.Text qualified as Text +import Data.Text ( Text ) +import Data.List as List + +import Text.Megaparsec hiding ( parse ) +import Text.Megaparsec.Char qualified as MC +import Data.Void + +import Data.Aeson + +-- TODO could add some integer instances to print them as hex too + +-- No harm in being polymorphic over the byte representation. +newtype Hex a = Hex { unHex :: a } + deriving stock (Generic, Data) + deriving Eq via a + +-- But most users will probably just want this. +type HexByteString = Hex B.ByteString + +instance Show (Hex B.ByteString) where + show = Text.unpack . prettyHexByteString B.unpack . unHex + +instance FromJSON (Hex B.ByteString) where + parseJSON = withText "hex bytestring" $ \t -> + case parseMaybe @Void (parseHexByteString B.pack) t of + Nothing -> fail "failed to parse hex bytestring (TODO)" + Just t' -> pure (Hex t') + +instance ToJSON (Hex B.ByteString) where + toJSON = String . prettyHexByteString B.unpack . unHex + +instance Show (Hex B.Short.ShortByteString) where + show = Text.unpack . prettyHexByteString B.Short.unpack . unHex + +instance FromJSON (Hex B.Short.ShortByteString) where + parseJSON = withText "hex bytestring" $ \t -> + case parseMaybe @Void (parseHexByteString B.Short.pack) t of + Nothing -> fail "failed to parse hex bytestring (TODO)" + Just t' -> pure (Hex t') + +instance ToJSON (Hex B.Short.ShortByteString) where + toJSON = String . prettyHexByteString B.Short.unpack . unHex + +-- | A hex bytestring looks like this: @00 01 89 8a FEff@. You can mix and +-- match capitalization and spacing, but I prefer to space each byte, full caps. +parseHexByteString + :: (MonadParsec e s m, Token s ~ Char) + => ([Word8] -> a) -> m a +parseHexByteString pack = pack <$> parseHexByte `sepBy` MC.hspace + +-- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both +-- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid. +-- +-- Returns a value 0-255, so can fit in any Num type that can store that. +parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a +parseHexByte = do + c1 <- MC.hexDigitChar + c2 <- MC.hexDigitChar + return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2) + +-- | Pretty print to default format @00 12 AB FF@: space between each byte, all +-- caps. +-- +-- This format I consider most human readable. I prefer caps to draw attention +-- to this being data instead of text (you don't see that many capital letters +-- packed together in prose). +prettyHexByteString :: (a -> [Word8]) -> a -> Text +prettyHexByteString unpack = + Text.concat + . List.intersperse (Text.singleton ' ') + . fmap (f . prettyHexByte Char.toUpper) + . unpack + where + f :: (Char, Char) -> Text + f (c1, c2) = Text.cons c1 $ Text.singleton c2 + +prettyHexByte :: (Char -> Char) -> Word8 -> (Char, Char) +prettyHexByte f w = (prettyNibble h, prettyNibble l) + where + (h,l) = fromIntegral w `divMod` 0x10 + prettyNibble = f . Char.intToDigit -- Char.intToDigit returns lower case + +-- | Pretty print to "compact" format @0012abff@ (often output by hashers). +prettyHexByteStringCompact :: (a -> [Word8]) -> a -> Text +prettyHexByteStringCompact unpack = + Text.concat . fmap (f . prettyHexByte id) . unpack + where + f :: (Char, Char) -> Text + f (c1, c2) = Text.cons c1 $ Text.singleton c2 diff --git a/src/Binrep/Generic.hs b/src/Binrep/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic.hs @@ -0,0 +1,49 @@ +-- | Derive 'BLen', 'Put', 'Get' and 'CBLen' instances generically. + +module Binrep.Generic + ( Cfg(..) + , cSumTagHex, cSumTagNullTerm, cDef + , blenGeneric, putGeneric, getGeneric, CBLenGeneric + ) where + +import Binrep.Generic.Internal +import Binrep.Generic.BLen +import Binrep.Generic.Put +import Binrep.Generic.Get +import Binrep.Generic.CBLen + +import Binrep.Type.ByteString ( AsByteString, Rep(..) ) +import Refined.Unsafe ( reallyUnsafeRefine ) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text + +import Numeric ( readHex ) + +-- TODO better error handling (see what aeson does) + +-- | 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 +cSumTagHex f = forceRead . readHex . f + +-- | Successfully parse exactly one result, or runtime error. +forceRead :: [(a, String)] -> a +forceRead = \case [] -> error "no parse" + [(x, "")] -> x + [(_x, _)] -> error "incomplete parse" + (_:_) -> error "too many parses (how??)" + +-- | Obtain the tag for a sum type value using the constructor name directly +-- (with a null terminator). +-- +-- This is probably not what you want in a binary representation, but it's safe +-- and may be useful for debugging. +-- +-- The refine force is safe under the assumption that Haskell constructor names +-- are UTF-8 with no null bytes allowed. I haven't confirmed that, but I'm +-- fairly certain. +cSumTagNullTerm :: String -> AsByteString 'C +cSumTagNullTerm = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack + +cDef :: Cfg (AsByteString 'C) +cDef = Cfg { cSumTag = cSumTagNullTerm } diff --git a/src/Binrep/Generic/BLen.hs b/src/Binrep/Generic/BLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic/BLen.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( + +module Binrep.Generic.BLen where + +import GHC.Generics +import GHC.TypeLits ( TypeError ) + +import Binrep.BLen +import Binrep.Generic.Internal + +blenGeneric :: (Generic a, GBLen (Rep a), BLen w) => Cfg w -> a -> BLenT +blenGeneric cfg = gblen cfg . from + +class GBLen f where + gblen :: BLen w => Cfg w -> f p -> BLenT + +-- | Empty constructor. +instance GBLen U1 where + gblen _ U1 = 0 + +-- | Field. +instance BLen c => GBLen (K1 i c) where + gblen _ (K1 c) = blen c + +-- | Product type fields are consecutive. +instance (GBLen l, GBLen r) => GBLen (l :*: r) where + gblen cfg (l :*: r) = gblen cfg l + gblen cfg r + +-- | Constructor sums are differentiated by a prefix tag. +instance GBLenSum (l :+: r) => GBLen (l :+: r) where + gblen = gblensum + +-- | Refuse to derive instance for void datatype. +instance TypeError GErrRefuseVoid => GBLen V1 where + gblen = undefined + +-- | Any datatype, constructor or record. +instance GBLen f => GBLen (M1 i d f) where + gblen cfg = gblen cfg . unM1 + +-------------------------------------------------------------------------------- + +class GBLenSum f where + gblensum :: BLen w => Cfg w -> f p -> BLenT + +instance (GBLenSum l, GBLenSum r) => GBLenSum (l :+: r) where + gblensum cfg = \case L1 l -> gblensum cfg l + R1 r -> gblensum cfg r + +instance (GBLen f, Constructor c) => GBLenSum (C1 c f) where + gblensum cfg x = blen ((cSumTag cfg) (conName' @c)) + gblen cfg (unM1 x) diff --git a/src/Binrep/Generic/CBLen.hs b/src/Binrep/Generic/CBLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic/CBLen.hs @@ -0,0 +1,72 @@ +{-# 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. + +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. + +You can attempt to derive a 'CBLen' type family instance generically for a type +via + + type instance CBLen a = CBLenGeneric w a + +As with deriving @BLen@, you must provide the type used to store the sum tag for +sum types. + +Then try doing something with it e.g. have GHC derive a @BLen@ instance for you +via the default method (that reifies CBLen) + + deriving anyclass BLen a + +Hopefully it either compiles, or you get a useful type error. If not, sorry. +-} + +module Binrep.Generic.CBLen where + +import Binrep.CBLen +import Binrep.Generic.Internal + +import GHC.Generics +import GHC.TypeLits +import Data.Kind + +import Data.Type.Equality +import Data.Type.Bool + +type CBLenGeneric w a = GCBLen w (Rep 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 GErrRefuseVoid + 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/Generic/Get.hs b/src/Binrep/Generic/Get.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic/Get.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( + +module Binrep.Generic.Get where + +import GHC.Generics +import GHC.TypeLits ( TypeError ) + +import Binrep.Get +import Binrep.Generic.Internal + +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 + +class GGet f where + gget :: (Get w, Eq w, Show w) => Cfg w -> Parser String (f a) + +-- | Empty constructor. +instance GGet U1 where + gget _ = return U1 + +-- | Field. +instance Get c => GGet (K1 i c) where + gget _ = K1 <$> get + +-- | 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 + +-- | 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 void datatype. +instance TypeError GErrRefuseVoid => GGet V1 where + gget = undefined + +-- | Any datatype, constructor or record. +instance GGet f => GGet (M1 i d f) where + gget cfg = M1 <$> gget cfg + +-------------------------------------------------------------------------------- + +class GGetSum f where + ggetsum :: (Get w, Eq w, Show w) => Cfg w -> w -> Maybe (Parser String (f a)) + +instance (GGetSum l, GGetSum r) => GGetSum (l :+: r) where + ggetsum cfg tag = l <|> r + where + l = fmap L1 <$> ggetsum cfg tag + r = fmap R1 <$> ggetsum cfg 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 diff --git a/src/Binrep/Generic/Internal.hs b/src/Binrep/Generic/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic/Internal.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Binrep.Generic.Internal where + +import GHC.TypeLits +import GHC.Generics + +data Cfg a = Cfg + { cSumTag :: String -> a + -- ^ How to turn a constructor name into a byte tag. + } + +-- | 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 diff --git a/src/Binrep/Generic/Put.hs b/src/Binrep/Generic/Put.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Generic/Put.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( + +module Binrep.Generic.Put where + +import GHC.Generics +import GHC.TypeLits ( TypeError ) + +import Binrep.Put +import Binrep.Generic.Internal + +putGeneric :: (Generic a, GPut (Rep a), Put w) => Cfg w -> a -> Builder +putGeneric cfg = gput cfg . from + +class GPut f where + gput :: Put w => Cfg w -> f p -> Builder + +-- | Empty constructor. +instance GPut U1 where + gput _ U1 = mempty + +-- | Field. +instance Put c => GPut (K1 i c) where + gput _ = put . unK1 + +-- | Product type fields are consecutive. +instance (GPut l, GPut r) => GPut (l :*: r) where + gput cfg (l :*: r) = gput cfg l <> gput cfg r + +-- | Constructor sums are differentiated by a prefix tag. +instance (GPutSum (l :+: r), GetConName (l :+: r)) => GPut (l :+: r) where + gput = gputsum + +-- | Refuse to derive instance for void datatype. +instance TypeError GErrRefuseVoid => GPut V1 where + gput = undefined + +-- | Any datatype, constructor or record. +instance GPut f => GPut (M1 i d f) where + gput cfg = gput cfg . unM1 + +-------------------------------------------------------------------------------- + +class GPutSum f where + gputsum :: Put w => Cfg w -> f a -> Builder + +instance (GPutSum l, GPutSum r) => GPutSum (l :+: r) where + gputsum cfg = \case L1 a -> gputsum cfg a + R1 a -> gputsum cfg a + +instance (GPut r, Constructor c) => GPutSum (C1 c r) where + gputsum cfg x = putTag <> putConstructor + where putTag = put $ (cSumTag cfg) (conName' @c) + putConstructor = gput cfg $ unM1 x + +--- + +-- | Get the name of the constructor of a sum datatype. +class GetConName f where + getConName :: f a -> String + +instance (GetConName a, GetConName b) => GetConName (a :+: b) where + getConName (L1 x) = getConName x + getConName (R1 x) = getConName x + +instance Constructor c => GetConName (C1 c a) where + getConName = conName diff --git a/src/Binrep/Get.hs b/src/Binrep/Get.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Get.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Binrep.Get + ( Getter, Get(..), runGet, runGetter + , GetWith(..), runGetWith + ) where + +import FlatParse.Basic qualified as FP +import FlatParse.Basic ( Parser ) +import Data.ByteString qualified as B +import Data.Word +import Data.Int +import GHC.Exts + +type Getter a = Parser String a + +class Get a where + -- | Parse from binary. + get :: Getter a + +runGet :: Get a => B.ByteString -> Either String (a, B.ByteString) +runGet = runGetter get + +runGetter :: Getter a -> B.ByteString -> Either String (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.Err e -> Left e + +-- | 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 + return as + +instance (Get a, Get b) => Get (a, b) where + get = do + a <- get + b <- get + return (a, b) + +instance Get B.ByteString where + get = FP.takeRestBs + +instance Get Word8 where get = FP.anyWord8 +instance Get Int8 where get = FP.anyInt8 + +-- | A type that can be parsed from binary given some environment. +-- +-- Making this levity polymorphic makes things pretty strange, but is useful. +-- See @Binrep.Example.FileTable@. +class GetWith (r :: TYPE rep) a | a -> r where + -- | Parse from binary with the given environment. + getWith :: r -> Getter a + -- can no longer provide default implementation due to levity polymorphism + --default getWith :: Get a => r -> Getter a + --getWith _ = get + +--deriving anyclass instance Get a => GetWith r [a] + +-- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You +-- can't bind (LHS) a levity polymorphic value. +runGetWith + :: GetWith (r :: TYPE LiftedRep) a + => r -> B.ByteString -> Either String (a, B.ByteString) +runGetWith r bs = runGetter (getWith r) bs diff --git a/src/Binrep/Predicates/NullPadTo.hs b/src/Binrep/Predicates/NullPadTo.hs deleted file mode 100644 --- a/src/Binrep/Predicates/NullPadTo.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Binrep.Predicates.NullPadTo where - -import Binrep.Codec -import Binrep.ByteLen -import Binrep.Util ( tshow ) -import Refined -import Refined.WithRefine -import Data.Serialize -import GHC.TypeNats -import Numeric.Natural -import GHC.Natural ( minusNaturalMaybe ) -import GHC.Exts ( proxy#, Proxy# ) -import Data.Typeable -import Data.ByteString qualified as BS - -data NullPadTo (n :: Nat) - -instance KnownNat n => ByteLen (WithRefine 'Enforced (NullPadTo n) a) where - blen = const n - where n = natVal' (proxy# :: Proxy# n) - -instance (ByteLen a, KnownNat n) => Predicate (NullPadTo n) a where - validate p a - | len > n - = throwRefineOtherException (typeRep p) $ - "too long: " <> tshow len <> " > " <> tshow n - | otherwise = success - where - n = natVal' (proxy# :: Proxy# n) - len = blen a - --- | predicate is inherently enforced due to checking length to calculate how --- many succeeding nulls to parse --- --- Note that the consumer probably doesn't care about the content of the --- padding, just that the data is chunked correctly. I figure we care about --- correctness here, so it'd be nice to know about the padding well-formedness --- (i.e. that it's all nulls). -instance (BinaryCodec a, ByteLen a, KnownNat n) - => BinaryCodec (WithRefine 'Enforced (NullPadTo n) a) where - fromBin = do - a <- fromBin - let len = blen a - case minusNaturalMaybe n len of - Nothing -> fail $ "too long: " <> show len <> " > " <> show n - Just nullstrLen -> do - getNNulls nullstrLen - return $ reallyUnsafeEnforce a - where - n = natVal' (proxy# :: Proxy# n) - toBin wrnpa = do - let npa = unWithRefine wrnpa - toBin npa - let paddingLength = n - blen npa - putByteString $ BS.replicate (fromIntegral paddingLength) 0x00 - where - n = natVal' (proxy# :: Proxy# n) - -getNNulls :: Natural -> Get () -getNNulls = \case 0 -> return () - n -> getWord8 >>= \case - 0x00 -> getNNulls $ n-1 - nonNull -> do - offset <- bytesRead - fail $ "expected null, found: "<> show nonNull - <> " at offset " <> show offset - <> ", " <> show n <> " more nulls to go" diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put.hs @@ -0,0 +1,63 @@ +module Binrep.Put where + +import Mason.Builder qualified as Mason + +import Data.ByteString qualified as B +import Data.Word +import Data.Int + +type Builder = Mason.BuilderFor Mason.StrictByteStringBackend + +class Put a where + -- | Serialize to binary. + put :: a -> Builder + +-- | Run the serializer. +runPut :: Put a => a -> B.ByteString +runPut = runBuilder . put + +runBuilder :: Builder -> B.ByteString +runBuilder = Mason.toStrictByteString + +-- | Serialize each element in order. No length indicator, so parse until either +-- error or EOF. Usually not what you want, but sometimes used at the "top" of +-- binary formats. +instance Put a => Put [a] where + put = mconcat . map put + +instance (Put a, Put b) => Put (a, b) where + put (a, b) = put a <> put b + +-- | Serialize the bytestring as-is. +-- +-- Careful -- the only way you're going to be able to parse this is to read +-- until EOF. +instance Put B.ByteString where + put = Mason.byteString + {-# INLINE put #-} + +-- need to give args for RankNTypes reasons I don't understand +instance Put Word8 where + put w = Mason.word8 w + {-# INLINE put #-} +instance Put Int8 where + put w = Mason.int8 w + {-# INLINE put #-} + +-- | Put with inlined checks via an environment. +class PutWith r a where + -- | Attempt to serialize to binary with the given environment. + putWith :: r -> a -> Either String Builder + default putWith :: Put a => r -> a -> Either String Builder + putWith _ = putWithout + +-- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding). +putWithout :: Put a => a -> Either String Builder +putWithout = Right . put + +instance Put a => PutWith r [a] + +-- | Run the serializer with the given environment. +runPutWith :: PutWith r a => r -> a -> Either String B.ByteString +runPutWith r a = case putWith r a of Left e -> Left e + Right x -> Right $ runBuilder x diff --git a/src/Binrep/Type/AsciiNat.hs b/src/Binrep/Type/AsciiNat.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/AsciiNat.hs @@ -0,0 +1,112 @@ +{-| Naturals represented via ASCII numerals. + +A concept which sees occasional use in places where neither speed nor size +efficiency matter. + +The tar file format uses it, apparently to sidestep making a decision on byte +ordering. Though digits are encoded "big-endian", so, uh. I don't get it. + +I don't really see the usage of these. It seems silly and inefficient, aimed +solely at easing debugging. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Binrep.Type.AsciiNat where + +import Binrep +import Binrep.Util ( natVal'' ) + +import Data.Word ( Word8 ) +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import Mason.Builder qualified as Mason +import Data.ByteString qualified as B +import Data.Semigroup ( sconcat ) + +import GHC.TypeNats ( Natural, KnownNat ) +import GHC.Num.Natural ( naturalSizeInBase#, naturalToWord# ) + +import GHC.Generics ( Generic ) +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). +-- +-- 'Show' instances display the stored number in the given base. If the base has +-- a common prefix (e.g. @0x@ for hex), it is used. +newtype AsciiNat (base :: Natural) = AsciiNat { getAsciiNat :: Natural } + deriving stock (Generic, Data) + deriving (Eq, Ord) via Natural + +instance Show (AsciiNat 2) where showsPrec _ n = showString "0b" . showBin (getAsciiNat n) +instance Show (AsciiNat 8) where showsPrec _ n = showString "0o" . showOct (getAsciiNat n) +instance Show (AsciiNat 10) where showsPrec _ n = showInt (getAsciiNat n) +instance Show (AsciiNat 16) where showsPrec _ n = showString "0x" . showHex (getAsciiNat n) + +-- | Compare two 'AsciiNat's with arbitrary bases. +asciiNatCompare :: AsciiNat b1 -> AsciiNat b2 -> Ordering +asciiNatCompare (AsciiNat n1) (AsciiNat n2) = compare n1 n2 + +-- | The bytelength of an 'AsciiNat' is the number of digits in the number in +-- the given base. We can calculate this generically with great efficiency +-- using GHC primitives. +instance KnownNat base => BLen (AsciiNat base) where + blen (AsciiNat n) = wordToBLen# (naturalSizeInBase# (naturalToWord# base) n) + where base = natVal'' @base + +-------------------------------------------------------------------------------- + +instance Put (AsciiNat 8) where + put = natToAsciiBytes (+ 0x30) 8 . getAsciiNat + +instance Get (AsciiNat 8) where + get = do + bs <- get + case asciiBytesToNat octalFromAsciiDigit 8 bs of + Left bs' -> FP.err $ "TODO " <> show bs' + Right n -> return $ AsciiNat n + +octalFromAsciiDigit :: Word8 -> Maybe Word8 +octalFromAsciiDigit = \case + 0x30 -> Just 0 + 0x31 -> Just 1 + 0x32 -> Just 2 + 0x33 -> Just 3 + 0x34 -> Just 4 + 0x35 -> Just 5 + 0x36 -> Just 6 + 0x37 -> Just 7 + _ -> Nothing + +-------------------------------------------------------------------------------- + +natToAsciiBytes :: (Word8 -> Word8) -> Natural -> Natural -> Builder +natToAsciiBytes f base = + sconcat . fmap (\w -> Mason.word8 w) . fmap f . digits @Word8 base + +asciiBytesToNat :: (Word8 -> Maybe Word8) -> Natural -> B.ByteString -> Either Word8 Natural +asciiBytesToNat f base bs = + case B.foldr go (Right (0, 0)) bs of + Left w -> Left w + Right (n, _) -> Right n + where + go :: Word8 -> Either Word8 (Natural, Natural) -> Either Word8 (Natural, Natural) + go _ (Left w) = Left w + go w (Right (n, expo)) = + case f w of + Nothing -> Left w + Just d -> Right (n + fromIntegral d * base^expo, expo+1) + +digits :: forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b +digits base = go [] + where + go s x = loop (head' :| s) tail' + where + head' = fromIntegral (x `mod` base) + tail' = x `div` base + loop s@(r :| rs) = \case + 0 -> s + x -> go (r : rs) x diff --git a/src/Binrep/Type/Byte.hs b/src/Binrep/Type/Byte.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Byte.hs @@ -0,0 +1,821 @@ +{- | Safe, if silly, byte representation for use at the type level. + +'Word8' is a special type that GHC doesn't (and I think can't) promote to the +type level. We only have 'Natural's, which are unbounded. So we define a safe, +promotable representation, to allow us to prove well-sizedness at compile time. +Then we provide a bunch of type families and reifying typeclasses to enable +going between "similar" kinds ('Natural') and types ('Word8', 'B.ByteString') +respectively. + +Type-level functionality is stored in 'Binrep.Type.Byte.TypeLevel' because the +definitions are even sillier than the ones here. + +Do not use this on the term level. That would be _extremely_ silly. +-} + +{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-} + +module Binrep.Type.Byte where + +import Mason.Builder qualified as Mason +import Data.ByteString.Builder.Prim.Internal qualified as BI +import Binrep.Util ( natVal'' ) +import Binrep.Put ( Builder ) +import GHC.TypeNats +import GHC.Exts + +-- Needs to be a function type to work. Interesting. It's perhaps not an +-- improvement on regular boxed. But interesting idea, so sticking with it. +class ByteVal (n :: Natural) where byteVal :: Proxy# n -> Word8# + +instance ByteVal 0x00 where + byteVal _ = wordToWord8# 0x00## + {-# INLINE byteVal #-} +instance ByteVal 0x01 where + byteVal _ = wordToWord8# 0x01## + {-# INLINE byteVal #-} +instance ByteVal 0x02 where + byteVal _ = wordToWord8# 0x02## + {-# INLINE byteVal #-} +instance ByteVal 0x03 where + byteVal _ = wordToWord8# 0x03## + {-# INLINE byteVal #-} +instance ByteVal 0x04 where + byteVal _ = wordToWord8# 0x04## + {-# INLINE byteVal #-} +instance ByteVal 0x05 where + byteVal _ = wordToWord8# 0x05## + {-# INLINE byteVal #-} +instance ByteVal 0x06 where + byteVal _ = wordToWord8# 0x06## + {-# INLINE byteVal #-} +instance ByteVal 0x07 where + byteVal _ = wordToWord8# 0x07## + {-# INLINE byteVal #-} +instance ByteVal 0x08 where + byteVal _ = wordToWord8# 0x08## + {-# INLINE byteVal #-} +instance ByteVal 0x09 where + byteVal _ = wordToWord8# 0x09## + {-# INLINE byteVal #-} +instance ByteVal 0x0a where + byteVal _ = wordToWord8# 0x0a## + {-# INLINE byteVal #-} +instance ByteVal 0x0b where + byteVal _ = wordToWord8# 0x0b## + {-# INLINE byteVal #-} +instance ByteVal 0x0c where + byteVal _ = wordToWord8# 0x0c## + {-# INLINE byteVal #-} +instance ByteVal 0x0d where + byteVal _ = wordToWord8# 0x0d## + {-# INLINE byteVal #-} +instance ByteVal 0x0e where + byteVal _ = wordToWord8# 0x0e## + {-# INLINE byteVal #-} +instance ByteVal 0x0f where + byteVal _ = wordToWord8# 0x0f## + {-# INLINE byteVal #-} +instance ByteVal 0x10 where + byteVal _ = wordToWord8# 0x10## + {-# INLINE byteVal #-} +instance ByteVal 0x11 where + byteVal _ = wordToWord8# 0x11## + {-# INLINE byteVal #-} +instance ByteVal 0x12 where + byteVal _ = wordToWord8# 0x12## + {-# INLINE byteVal #-} +instance ByteVal 0x13 where + byteVal _ = wordToWord8# 0x13## + {-# INLINE byteVal #-} +instance ByteVal 0x14 where + byteVal _ = wordToWord8# 0x14## + {-# INLINE byteVal #-} +instance ByteVal 0x15 where + byteVal _ = wordToWord8# 0x15## + {-# INLINE byteVal #-} +instance ByteVal 0x16 where + byteVal _ = wordToWord8# 0x16## + {-# INLINE byteVal #-} +instance ByteVal 0x17 where + byteVal _ = wordToWord8# 0x17## + {-# INLINE byteVal #-} +instance ByteVal 0x18 where + byteVal _ = wordToWord8# 0x18## + {-# INLINE byteVal #-} +instance ByteVal 0x19 where + byteVal _ = wordToWord8# 0x19## + {-# INLINE byteVal #-} +instance ByteVal 0x1a where + byteVal _ = wordToWord8# 0x1a## + {-# INLINE byteVal #-} +instance ByteVal 0x1b where + byteVal _ = wordToWord8# 0x1b## + {-# INLINE byteVal #-} +instance ByteVal 0x1c where + byteVal _ = wordToWord8# 0x1c## + {-# INLINE byteVal #-} +instance ByteVal 0x1d where + byteVal _ = wordToWord8# 0x1d## + {-# INLINE byteVal #-} +instance ByteVal 0x1e where + byteVal _ = wordToWord8# 0x1e## + {-# INLINE byteVal #-} +instance ByteVal 0x1f where + byteVal _ = wordToWord8# 0x1f## + {-# INLINE byteVal #-} +instance ByteVal 0x20 where + byteVal _ = wordToWord8# 0x20## + {-# INLINE byteVal #-} +instance ByteVal 0x21 where + byteVal _ = wordToWord8# 0x21## + {-# INLINE byteVal #-} +instance ByteVal 0x22 where + byteVal _ = wordToWord8# 0x22## + {-# INLINE byteVal #-} +instance ByteVal 0x23 where + byteVal _ = wordToWord8# 0x23## + {-# INLINE byteVal #-} +instance ByteVal 0x24 where + byteVal _ = wordToWord8# 0x24## + {-# INLINE byteVal #-} +instance ByteVal 0x25 where + byteVal _ = wordToWord8# 0x25## + {-# INLINE byteVal #-} +instance ByteVal 0x26 where + byteVal _ = wordToWord8# 0x26## + {-# INLINE byteVal #-} +instance ByteVal 0x27 where + byteVal _ = wordToWord8# 0x27## + {-# INLINE byteVal #-} +instance ByteVal 0x28 where + byteVal _ = wordToWord8# 0x28## + {-# INLINE byteVal #-} +instance ByteVal 0x29 where + byteVal _ = wordToWord8# 0x29## + {-# INLINE byteVal #-} +instance ByteVal 0x2a where + byteVal _ = wordToWord8# 0x2a## + {-# INLINE byteVal #-} +instance ByteVal 0x2b where + byteVal _ = wordToWord8# 0x2b## + {-# INLINE byteVal #-} +instance ByteVal 0x2c where + byteVal _ = wordToWord8# 0x2c## + {-# INLINE byteVal #-} +instance ByteVal 0x2d where + byteVal _ = wordToWord8# 0x2d## + {-# INLINE byteVal #-} +instance ByteVal 0x2e where + byteVal _ = wordToWord8# 0x2e## + {-# INLINE byteVal #-} +instance ByteVal 0x2f where + byteVal _ = wordToWord8# 0x2f## + {-# INLINE byteVal #-} +instance ByteVal 0x30 where + byteVal _ = wordToWord8# 0x30## + {-# INLINE byteVal #-} +instance ByteVal 0x31 where + byteVal _ = wordToWord8# 0x31## + {-# INLINE byteVal #-} +instance ByteVal 0x32 where + byteVal _ = wordToWord8# 0x32## + {-# INLINE byteVal #-} +instance ByteVal 0x33 where + byteVal _ = wordToWord8# 0x33## + {-# INLINE byteVal #-} +instance ByteVal 0x34 where + byteVal _ = wordToWord8# 0x34## + {-# INLINE byteVal #-} +instance ByteVal 0x35 where + byteVal _ = wordToWord8# 0x35## + {-# INLINE byteVal #-} +instance ByteVal 0x36 where + byteVal _ = wordToWord8# 0x36## + {-# INLINE byteVal #-} +instance ByteVal 0x37 where + byteVal _ = wordToWord8# 0x37## + {-# INLINE byteVal #-} +instance ByteVal 0x38 where + byteVal _ = wordToWord8# 0x38## + {-# INLINE byteVal #-} +instance ByteVal 0x39 where + byteVal _ = wordToWord8# 0x39## + {-# INLINE byteVal #-} +instance ByteVal 0x3a where + byteVal _ = wordToWord8# 0x3a## + {-# INLINE byteVal #-} +instance ByteVal 0x3b where + byteVal _ = wordToWord8# 0x3b## + {-# INLINE byteVal #-} +instance ByteVal 0x3c where + byteVal _ = wordToWord8# 0x3c## + {-# INLINE byteVal #-} +instance ByteVal 0x3d where + byteVal _ = wordToWord8# 0x3d## + {-# INLINE byteVal #-} +instance ByteVal 0x3e where + byteVal _ = wordToWord8# 0x3e## + {-# INLINE byteVal #-} +instance ByteVal 0x3f where + byteVal _ = wordToWord8# 0x3f## + {-# INLINE byteVal #-} +instance ByteVal 0x40 where + byteVal _ = wordToWord8# 0x40## + {-# INLINE byteVal #-} +instance ByteVal 0x41 where + byteVal _ = wordToWord8# 0x41## + {-# INLINE byteVal #-} +instance ByteVal 0x42 where + byteVal _ = wordToWord8# 0x42## + {-# INLINE byteVal #-} +instance ByteVal 0x43 where + byteVal _ = wordToWord8# 0x43## + {-# INLINE byteVal #-} +instance ByteVal 0x44 where + byteVal _ = wordToWord8# 0x44## + {-# INLINE byteVal #-} +instance ByteVal 0x45 where + byteVal _ = wordToWord8# 0x45## + {-# INLINE byteVal #-} +instance ByteVal 0x46 where + byteVal _ = wordToWord8# 0x46## + {-# INLINE byteVal #-} +instance ByteVal 0x47 where + byteVal _ = wordToWord8# 0x47## + {-# INLINE byteVal #-} +instance ByteVal 0x48 where + byteVal _ = wordToWord8# 0x48## + {-# INLINE byteVal #-} +instance ByteVal 0x49 where + byteVal _ = wordToWord8# 0x49## + {-# INLINE byteVal #-} +instance ByteVal 0x4a where + byteVal _ = wordToWord8# 0x4a## + {-# INLINE byteVal #-} +instance ByteVal 0x4b where + byteVal _ = wordToWord8# 0x4b## + {-# INLINE byteVal #-} +instance ByteVal 0x4c where + byteVal _ = wordToWord8# 0x4c## + {-# INLINE byteVal #-} +instance ByteVal 0x4d where + byteVal _ = wordToWord8# 0x4d## + {-# INLINE byteVal #-} +instance ByteVal 0x4e where + byteVal _ = wordToWord8# 0x4e## + {-# INLINE byteVal #-} +instance ByteVal 0x4f where + byteVal _ = wordToWord8# 0x4f## + {-# INLINE byteVal #-} +instance ByteVal 0x50 where + byteVal _ = wordToWord8# 0x50## + {-# INLINE byteVal #-} +instance ByteVal 0x51 where + byteVal _ = wordToWord8# 0x51## + {-# INLINE byteVal #-} +instance ByteVal 0x52 where + byteVal _ = wordToWord8# 0x52## + {-# INLINE byteVal #-} +instance ByteVal 0x53 where + byteVal _ = wordToWord8# 0x53## + {-# INLINE byteVal #-} +instance ByteVal 0x54 where + byteVal _ = wordToWord8# 0x54## + {-# INLINE byteVal #-} +instance ByteVal 0x55 where + byteVal _ = wordToWord8# 0x55## + {-# INLINE byteVal #-} +instance ByteVal 0x56 where + byteVal _ = wordToWord8# 0x56## + {-# INLINE byteVal #-} +instance ByteVal 0x57 where + byteVal _ = wordToWord8# 0x57## + {-# INLINE byteVal #-} +instance ByteVal 0x58 where + byteVal _ = wordToWord8# 0x58## + {-# INLINE byteVal #-} +instance ByteVal 0x59 where + byteVal _ = wordToWord8# 0x59## + {-# INLINE byteVal #-} +instance ByteVal 0x5a where + byteVal _ = wordToWord8# 0x5a## + {-# INLINE byteVal #-} +instance ByteVal 0x5b where + byteVal _ = wordToWord8# 0x5b## + {-# INLINE byteVal #-} +instance ByteVal 0x5c where + byteVal _ = wordToWord8# 0x5c## + {-# INLINE byteVal #-} +instance ByteVal 0x5d where + byteVal _ = wordToWord8# 0x5d## + {-# INLINE byteVal #-} +instance ByteVal 0x5e where + byteVal _ = wordToWord8# 0x5e## + {-# INLINE byteVal #-} +instance ByteVal 0x5f where + byteVal _ = wordToWord8# 0x5f## + {-# INLINE byteVal #-} +instance ByteVal 0x60 where + byteVal _ = wordToWord8# 0x60## + {-# INLINE byteVal #-} +instance ByteVal 0x61 where + byteVal _ = wordToWord8# 0x61## + {-# INLINE byteVal #-} +instance ByteVal 0x62 where + byteVal _ = wordToWord8# 0x62## + {-# INLINE byteVal #-} +instance ByteVal 0x63 where + byteVal _ = wordToWord8# 0x63## + {-# INLINE byteVal #-} +instance ByteVal 0x64 where + byteVal _ = wordToWord8# 0x64## + {-# INLINE byteVal #-} +instance ByteVal 0x65 where + byteVal _ = wordToWord8# 0x65## + {-# INLINE byteVal #-} +instance ByteVal 0x66 where + byteVal _ = wordToWord8# 0x66## + {-# INLINE byteVal #-} +instance ByteVal 0x67 where + byteVal _ = wordToWord8# 0x67## + {-# INLINE byteVal #-} +instance ByteVal 0x68 where + byteVal _ = wordToWord8# 0x68## + {-# INLINE byteVal #-} +instance ByteVal 0x69 where + byteVal _ = wordToWord8# 0x69## + {-# INLINE byteVal #-} +instance ByteVal 0x6a where + byteVal _ = wordToWord8# 0x6a## + {-# INLINE byteVal #-} +instance ByteVal 0x6b where + byteVal _ = wordToWord8# 0x6b## + {-# INLINE byteVal #-} +instance ByteVal 0x6c where + byteVal _ = wordToWord8# 0x6c## + {-# INLINE byteVal #-} +instance ByteVal 0x6d where + byteVal _ = wordToWord8# 0x6d## + {-# INLINE byteVal #-} +instance ByteVal 0x6e where + byteVal _ = wordToWord8# 0x6e## + {-# INLINE byteVal #-} +instance ByteVal 0x6f where + byteVal _ = wordToWord8# 0x6f## + {-# INLINE byteVal #-} +instance ByteVal 0x70 where + byteVal _ = wordToWord8# 0x70## + {-# INLINE byteVal #-} +instance ByteVal 0x71 where + byteVal _ = wordToWord8# 0x71## + {-# INLINE byteVal #-} +instance ByteVal 0x72 where + byteVal _ = wordToWord8# 0x72## + {-# INLINE byteVal #-} +instance ByteVal 0x73 where + byteVal _ = wordToWord8# 0x73## + {-# INLINE byteVal #-} +instance ByteVal 0x74 where + byteVal _ = wordToWord8# 0x74## + {-# INLINE byteVal #-} +instance ByteVal 0x75 where + byteVal _ = wordToWord8# 0x75## + {-# INLINE byteVal #-} +instance ByteVal 0x76 where + byteVal _ = wordToWord8# 0x76## + {-# INLINE byteVal #-} +instance ByteVal 0x77 where + byteVal _ = wordToWord8# 0x77## + {-# INLINE byteVal #-} +instance ByteVal 0x78 where + byteVal _ = wordToWord8# 0x78## + {-# INLINE byteVal #-} +instance ByteVal 0x79 where + byteVal _ = wordToWord8# 0x79## + {-# INLINE byteVal #-} +instance ByteVal 0x7a where + byteVal _ = wordToWord8# 0x7a## + {-# INLINE byteVal #-} +instance ByteVal 0x7b where + byteVal _ = wordToWord8# 0x7b## + {-# INLINE byteVal #-} +instance ByteVal 0x7c where + byteVal _ = wordToWord8# 0x7c## + {-# INLINE byteVal #-} +instance ByteVal 0x7d where + byteVal _ = wordToWord8# 0x7d## + {-# INLINE byteVal #-} +instance ByteVal 0x7e where + byteVal _ = wordToWord8# 0x7e## + {-# INLINE byteVal #-} +instance ByteVal 0x7f where + byteVal _ = wordToWord8# 0x7f## + {-# INLINE byteVal #-} +instance ByteVal 0x80 where + byteVal _ = wordToWord8# 0x80## + {-# INLINE byteVal #-} +instance ByteVal 0x81 where + byteVal _ = wordToWord8# 0x81## + {-# INLINE byteVal #-} +instance ByteVal 0x82 where + byteVal _ = wordToWord8# 0x82## + {-# INLINE byteVal #-} +instance ByteVal 0x83 where + byteVal _ = wordToWord8# 0x83## + {-# INLINE byteVal #-} +instance ByteVal 0x84 where + byteVal _ = wordToWord8# 0x84## + {-# INLINE byteVal #-} +instance ByteVal 0x85 where + byteVal _ = wordToWord8# 0x85## + {-# INLINE byteVal #-} +instance ByteVal 0x86 where + byteVal _ = wordToWord8# 0x86## + {-# INLINE byteVal #-} +instance ByteVal 0x87 where + byteVal _ = wordToWord8# 0x87## + {-# INLINE byteVal #-} +instance ByteVal 0x88 where + byteVal _ = wordToWord8# 0x88## + {-# INLINE byteVal #-} +instance ByteVal 0x89 where + byteVal _ = wordToWord8# 0x89## + {-# INLINE byteVal #-} +instance ByteVal 0x8a where + byteVal _ = wordToWord8# 0x8a## + {-# INLINE byteVal #-} +instance ByteVal 0x8b where + byteVal _ = wordToWord8# 0x8b## + {-# INLINE byteVal #-} +instance ByteVal 0x8c where + byteVal _ = wordToWord8# 0x8c## + {-# INLINE byteVal #-} +instance ByteVal 0x8d where + byteVal _ = wordToWord8# 0x8d## + {-# INLINE byteVal #-} +instance ByteVal 0x8e where + byteVal _ = wordToWord8# 0x8e## + {-# INLINE byteVal #-} +instance ByteVal 0x8f where + byteVal _ = wordToWord8# 0x8f## + {-# INLINE byteVal #-} +instance ByteVal 0x90 where + byteVal _ = wordToWord8# 0x90## + {-# INLINE byteVal #-} +instance ByteVal 0x91 where + byteVal _ = wordToWord8# 0x91## + {-# INLINE byteVal #-} +instance ByteVal 0x92 where + byteVal _ = wordToWord8# 0x92## + {-# INLINE byteVal #-} +instance ByteVal 0x93 where + byteVal _ = wordToWord8# 0x93## + {-# INLINE byteVal #-} +instance ByteVal 0x94 where + byteVal _ = wordToWord8# 0x94## + {-# INLINE byteVal #-} +instance ByteVal 0x95 where + byteVal _ = wordToWord8# 0x95## + {-# INLINE byteVal #-} +instance ByteVal 0x96 where + byteVal _ = wordToWord8# 0x96## + {-# INLINE byteVal #-} +instance ByteVal 0x97 where + byteVal _ = wordToWord8# 0x97## + {-# INLINE byteVal #-} +instance ByteVal 0x98 where + byteVal _ = wordToWord8# 0x98## + {-# INLINE byteVal #-} +instance ByteVal 0x99 where + byteVal _ = wordToWord8# 0x99## + {-# INLINE byteVal #-} +instance ByteVal 0x9a where + byteVal _ = wordToWord8# 0x9a## + {-# INLINE byteVal #-} +instance ByteVal 0x9b where + byteVal _ = wordToWord8# 0x9b## + {-# INLINE byteVal #-} +instance ByteVal 0x9c where + byteVal _ = wordToWord8# 0x9c## + {-# INLINE byteVal #-} +instance ByteVal 0x9d where + byteVal _ = wordToWord8# 0x9d## + {-# INLINE byteVal #-} +instance ByteVal 0x9e where + byteVal _ = wordToWord8# 0x9e## + {-# INLINE byteVal #-} +instance ByteVal 0x9f where + byteVal _ = wordToWord8# 0x9f## + {-# INLINE byteVal #-} +instance ByteVal 0xa0 where + byteVal _ = wordToWord8# 0xa0## + {-# INLINE byteVal #-} +instance ByteVal 0xa1 where + byteVal _ = wordToWord8# 0xa1## + {-# INLINE byteVal #-} +instance ByteVal 0xa2 where + byteVal _ = wordToWord8# 0xa2## + {-# INLINE byteVal #-} +instance ByteVal 0xa3 where + byteVal _ = wordToWord8# 0xa3## + {-# INLINE byteVal #-} +instance ByteVal 0xa4 where + byteVal _ = wordToWord8# 0xa4## + {-# INLINE byteVal #-} +instance ByteVal 0xa5 where + byteVal _ = wordToWord8# 0xa5## + {-# INLINE byteVal #-} +instance ByteVal 0xa6 where + byteVal _ = wordToWord8# 0xa6## + {-# INLINE byteVal #-} +instance ByteVal 0xa7 where + byteVal _ = wordToWord8# 0xa7## + {-# INLINE byteVal #-} +instance ByteVal 0xa8 where + byteVal _ = wordToWord8# 0xa8## + {-# INLINE byteVal #-} +instance ByteVal 0xa9 where + byteVal _ = wordToWord8# 0xa9## + {-# INLINE byteVal #-} +instance ByteVal 0xaa where + byteVal _ = wordToWord8# 0xaa## + {-# INLINE byteVal #-} +instance ByteVal 0xab where + byteVal _ = wordToWord8# 0xab## + {-# INLINE byteVal #-} +instance ByteVal 0xac where + byteVal _ = wordToWord8# 0xac## + {-# INLINE byteVal #-} +instance ByteVal 0xad where + byteVal _ = wordToWord8# 0xad## + {-# INLINE byteVal #-} +instance ByteVal 0xae where + byteVal _ = wordToWord8# 0xae## + {-# INLINE byteVal #-} +instance ByteVal 0xaf where + byteVal _ = wordToWord8# 0xaf## + {-# INLINE byteVal #-} +instance ByteVal 0xb0 where + byteVal _ = wordToWord8# 0xb0## + {-# INLINE byteVal #-} +instance ByteVal 0xb1 where + byteVal _ = wordToWord8# 0xb1## + {-# INLINE byteVal #-} +instance ByteVal 0xb2 where + byteVal _ = wordToWord8# 0xb2## + {-# INLINE byteVal #-} +instance ByteVal 0xb3 where + byteVal _ = wordToWord8# 0xb3## + {-# INLINE byteVal #-} +instance ByteVal 0xb4 where + byteVal _ = wordToWord8# 0xb4## + {-# INLINE byteVal #-} +instance ByteVal 0xb5 where + byteVal _ = wordToWord8# 0xb5## + {-# INLINE byteVal #-} +instance ByteVal 0xb6 where + byteVal _ = wordToWord8# 0xb6## + {-# INLINE byteVal #-} +instance ByteVal 0xb7 where + byteVal _ = wordToWord8# 0xb7## + {-# INLINE byteVal #-} +instance ByteVal 0xb8 where + byteVal _ = wordToWord8# 0xb8## + {-# INLINE byteVal #-} +instance ByteVal 0xb9 where + byteVal _ = wordToWord8# 0xb9## + {-# INLINE byteVal #-} +instance ByteVal 0xba where + byteVal _ = wordToWord8# 0xba## + {-# INLINE byteVal #-} +instance ByteVal 0xbb where + byteVal _ = wordToWord8# 0xbb## + {-# INLINE byteVal #-} +instance ByteVal 0xbc where + byteVal _ = wordToWord8# 0xbc## + {-# INLINE byteVal #-} +instance ByteVal 0xbd where + byteVal _ = wordToWord8# 0xbd## + {-# INLINE byteVal #-} +instance ByteVal 0xbe where + byteVal _ = wordToWord8# 0xbe## + {-# INLINE byteVal #-} +instance ByteVal 0xbf where + byteVal _ = wordToWord8# 0xbf## + {-# INLINE byteVal #-} +instance ByteVal 0xc0 where + byteVal _ = wordToWord8# 0xc0## + {-# INLINE byteVal #-} +instance ByteVal 0xc1 where + byteVal _ = wordToWord8# 0xc1## + {-# INLINE byteVal #-} +instance ByteVal 0xc2 where + byteVal _ = wordToWord8# 0xc2## + {-# INLINE byteVal #-} +instance ByteVal 0xc3 where + byteVal _ = wordToWord8# 0xc3## + {-# INLINE byteVal #-} +instance ByteVal 0xc4 where + byteVal _ = wordToWord8# 0xc4## + {-# INLINE byteVal #-} +instance ByteVal 0xc5 where + byteVal _ = wordToWord8# 0xc5## + {-# INLINE byteVal #-} +instance ByteVal 0xc6 where + byteVal _ = wordToWord8# 0xc6## + {-# INLINE byteVal #-} +instance ByteVal 0xc7 where + byteVal _ = wordToWord8# 0xc7## + {-# INLINE byteVal #-} +instance ByteVal 0xc8 where + byteVal _ = wordToWord8# 0xc8## + {-# INLINE byteVal #-} +instance ByteVal 0xc9 where + byteVal _ = wordToWord8# 0xc9## + {-# INLINE byteVal #-} +instance ByteVal 0xca where + byteVal _ = wordToWord8# 0xca## + {-# INLINE byteVal #-} +instance ByteVal 0xcb where + byteVal _ = wordToWord8# 0xcb## + {-# INLINE byteVal #-} +instance ByteVal 0xcc where + byteVal _ = wordToWord8# 0xcc## + {-# INLINE byteVal #-} +instance ByteVal 0xcd where + byteVal _ = wordToWord8# 0xcd## + {-# INLINE byteVal #-} +instance ByteVal 0xce where + byteVal _ = wordToWord8# 0xce## + {-# INLINE byteVal #-} +instance ByteVal 0xcf where + byteVal _ = wordToWord8# 0xcf## + {-# INLINE byteVal #-} +instance ByteVal 0xd0 where + byteVal _ = wordToWord8# 0xd0## + {-# INLINE byteVal #-} +instance ByteVal 0xd1 where + byteVal _ = wordToWord8# 0xd1## + {-# INLINE byteVal #-} +instance ByteVal 0xd2 where + byteVal _ = wordToWord8# 0xd2## + {-# INLINE byteVal #-} +instance ByteVal 0xd3 where + byteVal _ = wordToWord8# 0xd3## + {-# INLINE byteVal #-} +instance ByteVal 0xd4 where + byteVal _ = wordToWord8# 0xd4## + {-# INLINE byteVal #-} +instance ByteVal 0xd5 where + byteVal _ = wordToWord8# 0xd5## + {-# INLINE byteVal #-} +instance ByteVal 0xd6 where + byteVal _ = wordToWord8# 0xd6## + {-# INLINE byteVal #-} +instance ByteVal 0xd7 where + byteVal _ = wordToWord8# 0xd7## + {-# INLINE byteVal #-} +instance ByteVal 0xd8 where + byteVal _ = wordToWord8# 0xd8## + {-# INLINE byteVal #-} +instance ByteVal 0xd9 where + byteVal _ = wordToWord8# 0xd9## + {-# INLINE byteVal #-} +instance ByteVal 0xda where + byteVal _ = wordToWord8# 0xda## + {-# INLINE byteVal #-} +instance ByteVal 0xdb where + byteVal _ = wordToWord8# 0xdb## + {-# INLINE byteVal #-} +instance ByteVal 0xdc where + byteVal _ = wordToWord8# 0xdc## + {-# INLINE byteVal #-} +instance ByteVal 0xdd where + byteVal _ = wordToWord8# 0xdd## + {-# INLINE byteVal #-} +instance ByteVal 0xde where + byteVal _ = wordToWord8# 0xde## + {-# INLINE byteVal #-} +instance ByteVal 0xdf where + byteVal _ = wordToWord8# 0xdf## + {-# INLINE byteVal #-} +instance ByteVal 0xe0 where + byteVal _ = wordToWord8# 0xe0## + {-# INLINE byteVal #-} +instance ByteVal 0xe1 where + byteVal _ = wordToWord8# 0xe1## + {-# INLINE byteVal #-} +instance ByteVal 0xe2 where + byteVal _ = wordToWord8# 0xe2## + {-# INLINE byteVal #-} +instance ByteVal 0xe3 where + byteVal _ = wordToWord8# 0xe3## + {-# INLINE byteVal #-} +instance ByteVal 0xe4 where + byteVal _ = wordToWord8# 0xe4## + {-# INLINE byteVal #-} +instance ByteVal 0xe5 where + byteVal _ = wordToWord8# 0xe5## + {-# INLINE byteVal #-} +instance ByteVal 0xe6 where + byteVal _ = wordToWord8# 0xe6## + {-# INLINE byteVal #-} +instance ByteVal 0xe7 where + byteVal _ = wordToWord8# 0xe7## + {-# INLINE byteVal #-} +instance ByteVal 0xe8 where + byteVal _ = wordToWord8# 0xe8## + {-# INLINE byteVal #-} +instance ByteVal 0xe9 where + byteVal _ = wordToWord8# 0xe9## + {-# INLINE byteVal #-} +instance ByteVal 0xea where + byteVal _ = wordToWord8# 0xea## + {-# INLINE byteVal #-} +instance ByteVal 0xeb where + byteVal _ = wordToWord8# 0xeb## + {-# INLINE byteVal #-} +instance ByteVal 0xec where + byteVal _ = wordToWord8# 0xec## + {-# INLINE byteVal #-} +instance ByteVal 0xed where + byteVal _ = wordToWord8# 0xed## + {-# INLINE byteVal #-} +instance ByteVal 0xee where + byteVal _ = wordToWord8# 0xee## + {-# INLINE byteVal #-} +instance ByteVal 0xef where + byteVal _ = wordToWord8# 0xef## + {-# INLINE byteVal #-} +instance ByteVal 0xf0 where + byteVal _ = wordToWord8# 0xf0## + {-# INLINE byteVal #-} +instance ByteVal 0xf1 where + byteVal _ = wordToWord8# 0xf1## + {-# INLINE byteVal #-} +instance ByteVal 0xf2 where + byteVal _ = wordToWord8# 0xf2## + {-# INLINE byteVal #-} +instance ByteVal 0xf3 where + byteVal _ = wordToWord8# 0xf3## + {-# INLINE byteVal #-} +instance ByteVal 0xf4 where + byteVal _ = wordToWord8# 0xf4## + {-# INLINE byteVal #-} +instance ByteVal 0xf5 where + byteVal _ = wordToWord8# 0xf5## + {-# INLINE byteVal #-} +instance ByteVal 0xf6 where + byteVal _ = wordToWord8# 0xf6## + {-# INLINE byteVal #-} +instance ByteVal 0xf7 where + byteVal _ = wordToWord8# 0xf7## + {-# INLINE byteVal #-} +instance ByteVal 0xf8 where + byteVal _ = wordToWord8# 0xf8## + {-# INLINE byteVal #-} +instance ByteVal 0xf9 where + byteVal _ = wordToWord8# 0xf9## + {-# INLINE byteVal #-} +instance ByteVal 0xfa where + byteVal _ = wordToWord8# 0xfa## + {-# INLINE byteVal #-} +instance ByteVal 0xfb where + byteVal _ = wordToWord8# 0xfb## + {-# INLINE byteVal #-} +instance ByteVal 0xfc where + byteVal _ = wordToWord8# 0xfc## + {-# INLINE byteVal #-} +instance ByteVal 0xfd where + byteVal _ = wordToWord8# 0xfd## + {-# INLINE byteVal #-} +instance ByteVal 0xfe where + byteVal _ = wordToWord8# 0xfe## + {-# INLINE byteVal #-} +instance ByteVal 0xff where + byteVal _ = wordToWord8# 0xff## + {-# INLINE byteVal #-} + +type family Length (a :: [k]) :: Natural where + Length '[] = 0 + Length (a ': as) = 1 + Length as + +-- | Efficiently reify a list of type-level 'Byte's to a bytestring builder. +-- +-- 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) () + where + n = natVal'' @n + go = \() (Ptr p#) -> writeByteVals @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# = + case runRW# (writeWord8OffAddr# p# 0# w#) of + _ -> writeByteVals @ns (plusAddr# p# 1#) + where w# = byteVal @n proxy# diff --git a/src/Binrep/Type/ByteString.hs b/src/Binrep/Type/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/ByteString.hs @@ -0,0 +1,101 @@ +{- | Machine bytestrings. + +I mix string and bytestring terminology here due to bad C influences, but this +module is specifically interested in bytestrings and their encoding. String/text +encoding is handled in another module. + +Note that the length prefix predicate is also defined here... because that's +just Pascal-style bytestrings, extended to other types. I can't easily put it in +an orphan module, because we define byte length for *all length-prefixed types* +in one fell swoop. +-} + +-- TODO redocument. pretty all over the place + +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Type.ByteString where + +import Binrep +import Binrep.Type.Common ( Endianness ) +import Binrep.Type.Int +import Binrep.Util + +import Refined +import Refined.Unsafe + +import Data.ByteString qualified as B +import FlatParse.Basic qualified as FP +import FlatParse.Basic ( Parser ) +import Data.Word ( Word8 ) +import GHC.TypeNats ( KnownNat ) + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +import Data.Typeable ( Typeable, typeRep ) + +-- | Bytestring representation. +data Rep + = C + -- ^ C-style bytestring. Arbitrary length, terminated with a null byte. + -- Permits no null bytes inside the bytestring. + + | Pascal ISize Endianness + -- ^ Pascal-style bytestring. Length defined in a prefixing integer of given + -- size and endianness. + deriving stock (Generic, Data, Show, Eq) + +-- | 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 + +instance BLen (AsByteString 'C) where + blen cbs = posIntToBLen $ B.length (unrefine cbs) + 1 + +instance Put (AsByteString 'C) where + put = putCString . unrefine + +putCString :: B.ByteString -> Builder +putCString bs = put bs <> put @Word8 0x00 + +instance Get (AsByteString 'C) where + get = reallyUnsafeRefine <$> getCString + +instance (itype ~ I 'U size end, irep ~ IRep 'U size, KnownNat (CBLen irep)) => BLen (AsByteString ('Pascal size end)) where + blen pbs = cblen @itype + blen (unrefine pbs) + +instance (itype ~ I 'U size end, irep ~ IRep 'U size, Put itype, Num irep) => Put (AsByteString ('Pascal size end)) where + put pbs = put @itype (fromIntegral (B.length bs)) <> put bs + where bs = unrefine pbs + +instance (itype ~ I 'U size end, irep ~ IRep 'U size, Integral irep, Get itype) => Get (AsByteString ('Pascal size end)) where + get = do + len <- get @itype + bs <- FP.takeBs $ fromIntegral len + return $ reallyUnsafeRefine bs + +-- | A C-style bytestring must not contain any null bytes. +instance Predicate 'C B.ByteString where + validate p bs + | B.any (== 0x00) bs = throwRefineOtherException (typeRep p) $ + "null byte not permitted in in C-style bytestring" + | otherwise = success + +instance + ( irep ~ IRep 'U size + , Bounded irep, Integral irep + , Show irep, Typeable size, Typeable e + ) => Predicate ('Pascal size e) B.ByteString where + validate p bs + | len > fromIntegral max' + = throwRefineOtherException (typeRep p) $ + "bytestring too long for given length prefix type: " + <>tshow len<>" > "<>tshow max' + | otherwise = success + where + len = B.length bs + max' = maxBound @irep diff --git a/src/Binrep/Type/Common.hs b/src/Binrep/Type/Common.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Common.hs @@ -0,0 +1,10 @@ +module Binrep.Type.Common where + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +-- | Byte order. +data Endianness + = BE -- ^ big endian, MSB first. e.g. most network protocols + | LE -- ^ little endian, MSB last. e.g. most processor architectures + deriving stock (Generic, Data, Show, Eq) diff --git a/src/Binrep/Type/Int.hs b/src/Binrep/Type/Int.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Int.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE UndecidableInstances #-} + +{- TODO can I replace this with a closed newtype family?? idk if I even want to + it's just this is clumsy to use sometimes +-} + +module Binrep.Type.Int where + +import Binrep +import Binrep.Type.Common ( Endianness(..) ) +import Strongweak + +import Data.Word +import Data.Int +import Data.Aeson +import FlatParse.Basic qualified as FP +import Mason.Builder qualified as Mason + +import GHC.Generics ( Generic ) +import Data.Data ( Typeable, Data ) +import GHC.TypeNats + +-- | Wrapper type grouping machine integers (sign, size) along with an explicit +-- endianness. +-- +-- The internal representation is selected via a type family to correspond to +-- the relevant Haskell data type, so common overflow behaviour should match. +-- We derive lots of handy instances, so you may perform regular arithmetic on +-- pairs of these types. For example: +-- +-- >>> 255 + 1 :: I 'U 'I1 e +-- 0 +-- +-- >>> 255 + 1 :: I 'U 'I2 e +-- 256 +newtype I (sign :: ISign) (size :: ISize) (e :: Endianness) + = I { getI :: IRep sign size } + deriving stock (Generic) + +deriving instance (Data (IRep sign size), Typeable sign, Typeable size, Typeable e) => Data (I sign size e) +deriving via (IRep sign size) instance Show (IRep sign size) => Show (I sign size e) + +-- Steal various numeric instances from the representation types. +deriving via (IRep sign size) instance Eq (IRep sign size) => Eq (I sign size e) +deriving via (IRep sign size) instance Ord (IRep sign size) => Ord (I sign size e) +deriving via (IRep sign size) instance Bounded (IRep sign size) => Bounded (I sign size e) +deriving via (IRep sign size) instance Num (IRep sign size) => Num (I sign size e) +deriving via (IRep sign size) instance Real (IRep sign size) => Real (I sign size e) +deriving via (IRep sign size) instance Enum (IRep sign size) => Enum (I sign size e) +deriving via (IRep sign size) instance Integral (IRep sign size) => Integral (I sign size e) + +-- | Unsigned machine integers can be idealized as naturals. +instance (irep ~ IRep 'U size, Integral irep) => Weaken (I 'U size end) where + type Weak (I 'U size end) = Natural + weaken = fromIntegral +instance (irep ~ IRep 'U size, Integral irep, Bounded irep, Show irep, Typeable size, Typeable end) + => Strengthen (I 'U size end) where + strengthen = strengthenBounded + +-- | Signed machine integers can be idealized as integers. +instance (irep ~ IRep 'S size, Integral irep) => Weaken (I 'S size end) where + type Weak (I 'S size end) = Integer + weaken = fromIntegral +instance (irep ~ IRep 'S size, Integral irep, Bounded irep, Show irep, Typeable size, Typeable end) + => Strengthen (I 'S size end) where + strengthen = strengthenBounded + +-- | Machine integer sign. +data ISign + = S -- ^ signed + | U -- ^ unsigned + deriving stock (Generic, Data, Show, Eq) + +-- | Machine integer size in number of bytes. +data ISize = I1 | I2 | I4 | I8 + deriving stock (Generic, Data, Show, Eq) + +-- | Grouping for matching a signedness and size to a Haskell integer data type. +type family IRep (sign :: ISign) (size :: ISize) where + IRep 'U 'I1 = Word8 + IRep 'S 'I1 = Int8 + IRep 'U 'I2 = Word16 + IRep 'S 'I2 = Int16 + IRep 'U 'I4 = Word32 + IRep 'S 'I4 = Int32 + IRep 'U 'I8 = Word64 + IRep 'S 'I8 = Int64 + +-- Also steal Aeson instances. The parser applies bounding checks appropriately. +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 Put (I 'U 'I1 e) where put = put . getI +instance Get (I 'U 'I1 e) where get = I <$> get +instance Put (I 'S 'I1 e) where put = put . getI +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 Put (I 'U 'I2 'LE) where put (I i) = Mason.word16LE i +instance Get (I 'U 'I2 'LE) where get = I <$> FP.anyWord16le +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 Put (I 'S 'I2 'LE) where put (I i) = Mason.int16LE i +instance Get (I 'S 'I2 'LE) where get = I <$> FP.anyInt16le + +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 Put (I 'U 'I4 'LE) where put (I i) = Mason.word32LE i +instance Get (I 'U 'I4 'LE) where get = I <$> FP.anyWord32le +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 Put (I 'S 'I4 'LE) where put (I i) = Mason.int32LE i +instance Get (I 'S 'I4 'LE) where get = I <$> FP.anyInt32le + +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 Put (I 'U 'I8 'LE) where put (I i) = Mason.word64LE i +instance Get (I 'U 'I8 'LE) where get = I <$> FP.anyWord64le +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 Put (I 'S 'I8 'LE) where put (I i) = Mason.int64LE i +instance Get (I 'S 'I8 'LE) where get = I <$> FP.anyInt64le + +-- | Shortcut. +type family IMax (sign :: ISign) (size :: ISize) :: Natural where + IMax sign size = MaxBound (IRep sign size) + +-- | Restricted reflected version of @maxBound@. +type family MaxBound w :: Natural where + MaxBound Word8 = 255 + MaxBound Int8 = 127 + MaxBound Word16 = 65535 + MaxBound Int16 = 32767 + MaxBound Word32 = 4294967295 + MaxBound Int32 = 2147483647 + MaxBound Word64 = 18446744073709551615 + MaxBound Int64 = 9223372036854775807 diff --git a/src/Binrep/Type/LenPfx.hs b/src/Binrep/Type/LenPfx.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/LenPfx.hs @@ -0,0 +1,110 @@ +-- TODO cleanup proxy usage (can we be faster via unboxed @Proxy#@ s ?) + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Binrep.Type.LenPfx where + +import Binrep +import Strongweak +import Data.Either.Validation +import Binrep.Type.Vector ( getVector ) +import Binrep.Type.Common ( Endianness ) +import Binrep.Type.Int +import Binrep.Util ( natVal'' ) +import Data.Vector.Sized ( Vector ) +import Data.Vector.Sized qualified as V +import GHC.TypeNats +import GHC.TypeLits ( OrderingI(..) ) +import Data.Proxy ( Proxy(..) ) + +import GHC.Generics +import Data.Typeable ( Typeable ) + +-- | Holy shit - no need to do a smart constructor, it's simply impossible to +-- instantiate invalid values of this type! +data LenPfx (size :: ISize) (end :: Endianness) a = + forall n. (KnownNat n, n <= IMax 'U size) => LenPfx { unLenPfx :: Vector n a } + +-- uhhhhhhhhhh i dunno. TODO +instance Generic (LenPfx size end a) where + type Rep (LenPfx size end a) = Rec0 (LenPfx size end a) + from = K1 + to = unK1 + +instance Eq a => Eq (LenPfx size end a) where + (LenPfx a) == (LenPfx b) = vsEq a b + +-- TODO +instance Show a => Show (LenPfx size end a) where + show (LenPfx a) = "LenPfx ("<>show a<>")" + +vsEq :: forall a n m. (Eq a, KnownNat n, KnownNat m) => Vector n a -> Vector m a -> Bool +vsEq vn vm = + if natVal'' @n == natVal'' @m + then V.toList vn == V.toList vm + else False + +instance Weaken (LenPfx size end a) where + type Weak (LenPfx size end a) = [a] + weaken (LenPfx v) = V.toList v + +instance (KnownNat (MaxBound (IRep 'U size)), Show a, Typeable a, Typeable size, Typeable end) + => Strengthen (LenPfx size end a) where + strengthen l = case lenPfxFromList l of + Nothing -> strengthenFailBase l "TODO doesn't fit" + Just v -> Success v + +asLenPfx + :: forall size end n a irep + . (irep ~ IRep 'U size, KnownNat n, KnownNat (MaxBound irep)) + => Vector n a -> Maybe (LenPfx size end a) +asLenPfx v = + case cmpNat (Proxy :: Proxy n) (Proxy :: Proxy (MaxBound (IRep 'U size))) of + LTI -> Just $ LenPfx v + EQI -> Just $ LenPfx v + GTI -> Nothing + +lenPfxFromList + :: forall size end a irep + . (irep ~ IRep 'U size, KnownNat (MaxBound irep)) + => [a] -> Maybe (LenPfx size end a) +lenPfxFromList l = V.withSizedList l asLenPfx + +instance (BLen a, itype ~ I 'U size end, KnownNat (CBLen itype)) + => BLen (LenPfx size end a) where + blen (LenPfx v) = cblen @itype + blen v + +instance (itype ~ I 'U size end, irep ~ IRep 'U size, Put a, Put itype, Num irep) + => Put (LenPfx size end a) where + put (LenPfx v) = put @itype (fromIntegral (vnatVal v)) <> put v + where + vnatVal :: forall n x. KnownNat n => Vector n x -> Natural + vnatVal _ = natVal'' @n + +lenPfxSize :: Num (IRep 'U size) => LenPfx size end a -> I 'U size end +lenPfxSize (LenPfx v) = fromIntegral (vnatVal v) + where + vnatVal :: forall n x. KnownNat n => Vector n x -> Natural + vnatVal _ = natVal'' @n + +instance (itype ~ I 'U size end, irep ~ IRep 'U size, Get itype, Integral irep, Get a, KnownNat (MaxBound irep)) + => Get (LenPfx size end a) where + get = getLenPfx get + +getLenPfx + :: forall size end a itype irep + . (itype ~ I 'U size end, irep ~ IRep 'U size, Get itype, Integral irep, KnownNat (MaxBound irep)) + => Getter a -> Getter (LenPfx size end a) +getLenPfx g = do + len <- get @itype + case someNatVal (fromIntegral len) of + SomeNat (Proxy :: Proxy n) -> do + x <- getVector @n g + -- TODO we actually know that @n <= MaxBound irep@ before doing this + -- because @len <= maxBound (_ :: irep)@ but that's hard to prove to + -- GHC without lots of refactoring. This is good enough. + case cmpNat (Proxy :: Proxy n) (Proxy :: Proxy (MaxBound irep)) of + GTI -> error "impossible" + LTI -> return $ LenPfx x + EQI -> return $ LenPfx x diff --git a/src/Binrep/Type/Magic.hs b/src/Binrep/Type/Magic.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Magic.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE UndecidableInstances #-} + +{- | 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.) + +TODO unassociated type fams bad (maybe). turn into class -- and turn the reifier +into a default method! (TODO think about this) + +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. + +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'. +-} + +module Binrep.Type.Magic where + +import Binrep +import Binrep.Type.Byte + +import GHC.TypeLits +import Data.ByteString qualified as B +import FlatParse.Basic qualified as FP + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +import Mason.Builder qualified as Mason + +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) + +-- | Assumes magic values are individual bytes. +deriving anyclass instance KnownNat (Length (MagicVals a)) => BLen (Magic a) + +-- | Forces magic values to be individual bytes. +instance (bs ~ MagicVals a, ByteVals bs) => Put (Magic a) where + put Magic = byteVals @bs + +-- | 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 + get = do + let expected = Mason.toStrictByteString $ byteVals @bs + actual <- FP.takeBs $ B.length expected + if actual == expected + then return Magic + else FP.err $ "bad magic: expected "<>show expected<>", got "<>show actual + +{- +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. +-} + +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) + +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) diff --git a/src/Binrep/Type/Magic/UTF8.hs b/src/Binrep/Type/Magic/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Magic/UTF8.hs @@ -0,0 +1,47 @@ +{- | Inefficient attempt at UTF-8 magics. + +To encode UTF-8 strings to bytestrings at compile time, we really need more +support from the compiler. We can go @Char -> Natural@, but we can't go @Natural +-> [Natural]@ where each value is @<= 255@. Doing so is hard without bit +twiddling. + +The best we can do is get reify the 'Symbol' directly, then encode as UTF-8 at +runtime. It's a bit of a farce, and we can't derive a 'CBLen' instance, but +works just fine. Actually, I dunno, it might be faster than the bytewise magic +handling, depending on how GHC optimizes its instances. +-} + +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Binrep.Type.Magic.UTF8 where + +import Binrep + +import GHC.TypeLits +import GHC.Exts ( proxy#, Proxy# ) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.ByteString qualified as B +import FlatParse.Basic qualified as FP + +data MagicUTF8 (str :: Symbol) = MagicUTF8 deriving Show + +symVal :: forall str. KnownSymbol str => String +symVal = symbolVal' (proxy# :: Proxy# str) + +instance KnownSymbol str => BLen (MagicUTF8 str) where + blen MagicUTF8 = posIntToBLen $ B.length $ encodeStringUtf8 $ symVal @str + +instance KnownSymbol str => Put (MagicUTF8 str) where + put MagicUTF8 = put $ encodeStringUtf8 $ symVal @str + +instance KnownSymbol str => Get (MagicUTF8 str) where + get = do + let expected = encodeStringUtf8 $ symVal @str + actual <- FP.takeBs $ B.length expected + if actual == expected + then return MagicUTF8 + else FP.err $ "bad magic: expected "<>show expected<>", got "<>show actual + +encodeStringUtf8 :: String -> B.ByteString +encodeStringUtf8 = Text.encodeUtf8 . Text.pack diff --git a/src/Binrep/Type/NullPadded.hs b/src/Binrep/Type/NullPadded.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/NullPadded.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Type.NullPadded where + +import Binrep +import Binrep.Util ( tshow ) + +import Refined +import Refined.Unsafe + +import GHC.TypeNats +import Data.Typeable ( typeRep ) +import FlatParse.Basic qualified as FP +import FlatParse.Basic ( Parser ) +import Mason.Builder qualified as Mason +import Data.ByteString qualified as BS + +data NullPad (n :: Natural) + +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 (BLen a, KnownNat n) => Predicate (NullPad n) a where + validate p a + | len > n + = throwRefineOtherException (typeRep p) $ + "too long: " <> tshow len <> " > " <> tshow n + | otherwise = success + where + n = typeNatToBLen @n + len = blen a + +-- TODO cleanup +instance (Put a, BLen a, KnownNat n) => Put (NullPadded n a) where + put wrnpa = + let npa = unrefine wrnpa + paddingLength = n - blen npa + in put npa <> Mason.byteString (BS.replicate (fromIntegral paddingLength) 0x00) + where + n = typeNatToBLen @n + +-- | Safety: we assert actual length is within expected length (in order to +-- calculate how much padding to parse). +-- +-- Note that the consumer probably doesn't care about the content of the +-- padding, just that the data is chunked correctly. I figure we care about +-- correctness here, so it'd be nice to know about the padding well-formedness +-- (i.e. that it's all nulls). +-- +-- TODO maybe better definition via isolate +instance (Get a, BLen a, KnownNat n) => Get (NullPadded n a) where + get = do + a <- get + let len = blen a + nullStrLen = n - len + if nullStrLen < 0 + then FP.err $ "too long: " <> show len <> " > " <> show n + else getNNulls nullStrLen >> return (reallyUnsafeRefine a) + where + n = typeNatToBLen @n + +getNNulls :: BLenT -> Parser String () +getNNulls = \case 0 -> return () + n -> FP.anyWord8 >>= \case + 0x00 -> getNNulls $ n-1 + nonNull -> FP.err "TODO expected null, wasn't" diff --git a/src/Binrep/Type/Sized.hs b/src/Binrep/Type/Sized.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Sized.hs @@ -0,0 +1,44 @@ +-- | Constant-size data. + +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Type.Sized where + +import Binrep +import Binrep.Util ( tshow ) + +import Refined +import Refined.Unsafe + +import GHC.TypeNats +import Data.Typeable ( typeRep ) +import FlatParse.Basic qualified as FP + +data Size (n :: Natural) + +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 (BLen a, KnownNat n) => Predicate (Size n) a where + validate p a + | len > n + = throwRefineOtherException (typeRep p) $ + "not correctly sized: "<>tshow len<>" /= "<>tshow n + | otherwise = success + where + n = typeNatToBLen @n + len = blen a + +instance Put a => Put (Sized n a) where + put = put . unrefine + +-- TODO safety: isolate consumes all bytes if succeeds +instance (Get a, KnownNat n) => Get (Sized n a) where + get = do + a <- FP.isolate (fromIntegral n) get + return $ reallyUnsafeRefine a + where + n = typeNatToBLen @n diff --git a/src/Binrep/Type/Text.hs b/src/Binrep/Type/Text.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} + +module Binrep.Type.Text + ( Encoding(..) + , AsText + , Encode, encode + , Decode(..) + , encodeToRep + , decodeViaTextICU + ) where + +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.ByteString ( Rep ) + +import Refined +import Refined.Unsafe + +import Data.ByteString qualified as B +import Data.Text qualified as Text +import Data.Text ( Text ) +import Data.Char qualified as Char +import Data.Text.Encoding qualified as Text +import Data.Either.Combinators qualified as Either + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) + +import Data.Typeable ( Typeable, typeRep ) + +import System.IO.Unsafe qualified +import Control.Exception qualified +import Data.Text.Encoding.Error qualified + +import Data.Text.ICU.Convert qualified as ICU + +type Bytes = B.ByteString + +-- | Character encoding. +-- +-- Byte-oriented encodings like ASCII and UTF-8 don't need to worry about +-- endianness. For UTF-16 and UTF-32, the designers decided to allow different +-- endiannesses, rather than saying "codepoints must be X-endian". +data Encoding + = UTF8 + | UTF16 Endianness + | UTF32 Endianness + | ASCII -- ^ 7-bit + | SJIS + deriving stock (Generic, Data, Show, Eq) + +-- | A string of a given encoding, stored in the 'Text' type. +type AsText (enc :: Encoding) = Refined enc Text + +-- | Bytestring encoders for text validated for a given encoding. +class Encode (enc :: Encoding) where + -- | Encode text to bytes. Internal function, use 'encode'. + encode' :: Text -> Bytes + +instance Encode 'UTF8 where encode' = Text.encodeUtf8 + +-- | ASCII is a subset of UTF-8, so valid ASCII is valid UTF-8, so this is safe. +instance Encode 'ASCII where encode' = encode' @'UTF8 + +instance Encode ('UTF16 'BE) where encode' = Text.encodeUtf16BE +instance Encode ('UTF16 'LE) where encode' = Text.encodeUtf16LE +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 + +-- | Any 'Text' value is always valid UTF-8. +instance Predicate 'UTF8 Text where validate _ _ = success + +-- | Any 'Text' value is always valid UTF-16. +instance Typeable e => Predicate ('UTF16 e) Text where validate _ _ = success + +-- | Any 'Text' value is always valid UTF-32. +instance Typeable e => Predicate ('UTF32 e) Text where validate _ _ = success + +-- | 'Text' must be validated if you want to permit 7-bit ASCII only. +instance Predicate 'ASCII Text where + validate p t = if Text.all Char.isAscii t + then success + else throwRefineOtherException (typeRep p) "not valid 7-bit ASCII" + +-- | TODO Unsafely assume all 'Text's are valid Shift-JIS. +instance Predicate 'SJIS Text where validate _ _ = success + +class Decode (enc :: Encoding) where + -- | Decode a 'ByteString' to 'Text' with an explicit encoding. + -- + -- This is intended to be used with visible type applications. + decode :: Bytes -> Either String (AsText enc) + +instance Decode 'UTF8 where decode = decodeText show Text.decodeUtf8' +instance Decode ('UTF16 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16BE +instance Decode ('UTF16 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16LE +instance Decode ('UTF32 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32BE +instance Decode ('UTF32 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32LE + +-- Pre-@text-2.0@, @decodeASCII@ generated a warning and ran @decodeUtf8@. +#if MIN_VERSION_text(2,0,0) +instance Decode 'ASCII where decode = decodeText $ wrapUnsafeDecoder Text.decodeASCII +#endif + +instance Decode 'SJIS where decode = decodeText id $ decodeViaTextICU' "Shift-JIS" + +-------------------------------------------------------------------------------- +-- Helpers + +-- | Encode some text to a bytestring, asserting that the resulting value is +-- valid for the requested bytestring representation. +-- +-- This is intended to be used with visible type applications: +-- +-- >>> let Right t = refine @'UTF8 (Text.pack "hi") +-- >>> :t t +-- t :: AsText 'UTF8 +-- >>> let Right bs = encodeToRep @'C t +-- >>> :t bs +-- bs :: Refined 'C Bytes +encodeToRep + :: forall (rep :: Rep) enc + . (Encode enc, Predicate rep Bytes) + => AsText enc + -> Either RefineException (Refined rep Bytes) +encodeToRep = refine . encode + +-------------------------------------------------------------------------------- +-- Internal helpers + +-- | Helper for decoding a 'Bytes' to a 'Text' tagged with its encoding. +decodeText + :: forall enc e + . (e -> String) -> (Bytes -> Either e Text) -> Bytes + -> Either String (AsText enc) +decodeText g f = Either.mapBoth g reallyUnsafeRefine . f + +-- | Run an unsafe decoder safely. +-- +-- Copied from @Data.Text.Encoding.decodeUtf8'@, so should be bulletproof? +wrapUnsafeDecoder + :: (Bytes -> Text) + -> Bytes -> Either Data.Text.Encoding.Error.UnicodeException Text +wrapUnsafeDecoder f = + System.IO.Unsafe.unsafeDupablePerformIO + . Control.Exception.try + . Control.Exception.evaluate + . f + +-- | Encode some 'Text' to the given character set using text-icu. +-- +-- No guarantees about correctness. Encodings are weird. e.g. Shift JIS's +-- yen/backslash problem is apparently to do with OSs treating it differently. +-- +-- Expects a 'Text' that is confirmed valid for converting to the character set. +-- +-- The charset must be valid, or it's exception time. See text-icu. +encodeViaTextICU :: String -> Text -> IO B.ByteString +encodeViaTextICU charset t = do + conv <- ICU.open charset Nothing + return $ ICU.fromUnicode conv t + +encodeViaTextICU' :: String -> Text -> B.ByteString +encodeViaTextICU' charset t = + System.IO.Unsafe.unsafeDupablePerformIO $ encodeViaTextICU charset t + +-- TODO Shitty library doesn't let us say how to handle errors. Apparently, the +-- only solution is to scan through the resulting 'Text' to look for @\SUB@ +-- characters, or lie about correctness. Sigh. +decodeViaTextICU :: String -> B.ByteString -> IO (Either String Text) +decodeViaTextICU charset t = do + conv <- ICU.open charset Nothing + return $ Right $ ICU.toUnicode conv t + +decodeViaTextICU' :: String -> B.ByteString -> Either String Text +decodeViaTextICU' charset t = do + System.IO.Unsafe.unsafeDupablePerformIO $ decodeViaTextICU charset t diff --git a/src/Binrep/Type/Vector.hs b/src/Binrep/Type/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Vector.hs @@ -0,0 +1,26 @@ +-- | Sized vectors. + +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Binrep.Type.Vector where + +import Binrep +import Data.Vector.Sized qualified as V +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 + blen = V.sum . V.map blen + +instance Put a => Put (Vector n a) where + put = mconcat . V.toList . V.map put + +instance (Get a, KnownNat n) => Get (Vector n a) where + get = getVector get + +getVector :: KnownNat n => Getter a -> Getter (Vector n a) +getVector g = V.replicateM g diff --git a/src/Binrep/Types/Ints.hs b/src/Binrep/Types/Ints.hs deleted file mode 100644 --- a/src/Binrep/Types/Ints.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Binrep.Types.Ints where - -import Binrep.Codec -import Binrep.ByteLen -import GHC.Generics ( Generic ) -import Data.Typeable -import Data.Word -import Data.Int -import Data.Aeson -import Data.Serialize - --- | Wrapper type grouping machine integers (sign, size) along with an explicit --- endianness. -newtype I (sign :: ISign) (size :: ISize) (e :: Endianness) - = I { getI :: IRep sign size } - deriving stock (Generic, Typeable) - --- | Lots of deriving boilerplate due to the type family usage. -deriving stock instance Show (IRep sign size) => Show (I sign size e) -deriving via (IRep sign size) instance Eq (IRep sign size) => Eq (I sign size e) -deriving via (IRep sign size) instance Ord (IRep sign size) => Ord (I sign size e) -deriving via (IRep sign size) instance Bounded (IRep sign size) => Bounded (I sign size e) -deriving via (IRep sign size) instance Num (IRep sign size) => Num (I sign size e) -deriving via (IRep sign size) instance Real (IRep sign size) => Real (I sign size e) -deriving via (IRep sign size) instance Enum (IRep sign size) => Enum (I sign size e) -deriving via (IRep sign size) instance Integral (IRep sign size) => Integral (I sign size e) -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) - -instance ByteLen (I s 'I1 e) where blen = const 1 -instance ByteLen (I s 'I2 e) where blen = const 2 -instance ByteLen (I s 'I4 e) where blen = const 4 -instance ByteLen (I s 'I8 e) where blen = const 8 - --- | Endianness doesn't apply for single-byte machine integers. -instance BinaryCodec (I 'U 'I1 e) where toBin = putWord8 . getI - fromBin = I <$> getWord8 -instance BinaryCodec (I 'S 'I1 e) where toBin = putInt8 . getI - fromBin = I <$> getInt8 - -instance BinaryCodec (I 'U 'I2 'BE) where toBin = putWord16be . getI - fromBin = I <$> getWord16be -instance BinaryCodec (I 'U 'I2 'LE) where toBin = putWord16le . getI - fromBin = I <$> getWord16le -instance BinaryCodec (I 'S 'I2 'BE) where toBin = putInt16be . getI - fromBin = I <$> getInt16be -instance BinaryCodec (I 'S 'I2 'LE) where toBin = putInt16le . getI - fromBin = I <$> getInt16le - -instance BinaryCodec (I 'U 'I4 'BE) where toBin = putWord32be . getI - fromBin = I <$> getWord32be -instance BinaryCodec (I 'U 'I4 'LE) where toBin = putWord32le . getI - fromBin = I <$> getWord32le -instance BinaryCodec (I 'S 'I4 'BE) where toBin = putInt32be . getI - fromBin = I <$> getInt32be -instance BinaryCodec (I 'S 'I4 'LE) where toBin = putInt32le . getI - fromBin = I <$> getInt32le - -instance BinaryCodec (I 'U 'I8 'BE) where toBin = putWord64be . getI - fromBin = I <$> getWord64be -instance BinaryCodec (I 'U 'I8 'LE) where toBin = putWord64le . getI - fromBin = I <$> getWord64le -instance BinaryCodec (I 'S 'I8 'BE) where toBin = putInt64be . getI - fromBin = I <$> getInt64be -instance BinaryCodec (I 'S 'I8 'LE) where toBin = putInt64le . getI - fromBin = I <$> getInt64le - --- | Byte order. -data Endianness - = BE -- ^ big endian, MSB first. e.g. most network protocols - | LE -- ^ little endian, MSB last. e.g. most processor architectures - --- | Machine integer sign -data ISign - = S -- ^ signed - | U -- ^ unsigned - --- | Machine integer size in number of bytes. -data ISize = I1 | I2 | I4 | I8 - -type family IRep (sign :: ISign) (size :: ISize) where - IRep 'U 'I1 = Word8 - IRep 'S 'I1 = Int8 - IRep 'U 'I2 = Word16 - IRep 'S 'I2 = Int16 - IRep 'U 'I4 = Word32 - IRep 'S 'I4 = Int32 - IRep 'U 'I8 = Word64 - IRep 'S 'I8 = Int64 diff --git a/src/Binrep/Types/Strings.hs b/src/Binrep/Types/Strings.hs deleted file mode 100644 --- a/src/Binrep/Types/Strings.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Binrep.Types.Strings where - -import Binrep.Codec -import Binrep.ByteLen -import Binrep.Types.Ints -import Binrep.Util -import Refined -import Refined.WithRefine -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BL -import Data.ByteString.Builder qualified as B -import Data.Serialize -import Data.Word -import Data.Typeable ( Typeable, typeRep ) -import Control.Monad ( replicateM ) - --- | TODO -data StrRep = C | Pascal ISize Endianness - --- | TODO --- --- We also use this as a predicate, because the 'Pascal' constructor looks --- identical to what we would want for a @LengthPrefixed@ predicate. -newtype Str (rep :: StrRep) - = Str { getStr :: BS.ByteString } - -fromBinCString :: Get BS.ByteString -fromBinCString = go mempty - where go buf = do - getWord8 >>= \case - 0x00 -> return $ BL.toStrict $ B.toLazyByteString buf - nonNull -> go $ buf <> B.word8 nonNull - -instance ByteLen (Str 'C) where - blen cstr = fromIntegral $ BS.length (getStr cstr) + 1 - -instance ByteLen (I 'U size e) => ByteLen (Str ('Pascal size e )) where - blen pstr = fromIntegral (blen @(I 'U size e) undefined) + fromIntegral (BS.length (getStr pstr)) - --- | Total shite parsing efficiency. But, to be fair, that's why we don't --- serialize arbitrary-length C strings! -instance BinaryCodec (Str 'C) where - toBin cstr = do - putByteString $ getStr cstr - putWord8 0x00 - fromBin = Str <$> fromBinCString - -instance BinaryCodecWith _r (Str 'C) - --- TODO yeah I gotta do this because now the size info is actually in the --- newtype -- which makes the most sense, because I want to do similar on the --- value level! looks a tiny bit jank but ✓ -data WellSized - --- | TODO explain why safe -instance BinaryCodec (WithRefine 'Enforced WellSized (Str ('Pascal 'I1 e))) where - toBin wrepstr = do - toBin @(I 'U 'I1 e) $ fromIntegral $ BS.length bs - putByteString bs - where bs = getStr $ unWithRefine wrepstr - fromBin = do - len <- fromBin @(I 'U 'I1 e) - bs <- getByteString $ fromIntegral len - return $ reallyUnsafeEnforce $ Str bs - -instance BinaryCodecWith StrRep BS.ByteString where - toBinWith strRep bs = - case strRep of - C -> toBinWith undefined $ Str @'C bs - Pascal size _e -> do - case size of - I1 -> do - if len > fromIntegral (maxBound @Word8) - then Left "bytestring too long for configured static-size length prefix" - else Right $ B.byteString bs - _ -> undefined - where len = BS.length bs - fromBinWith = \case C -> fromBinCString - Pascal _size _e -> undefined - --- Fun and correct, but it does give us an orphan instance lol -type LenPfx size e = Str ('Pascal size e) - --- | TODO why safe -instance (ByteLen a, itype ~ I 'U size e, ByteLen itype) - => ByteLen (WithRefine 'Enforced (LenPfx size e) a) where - blen wrelpa = blen @itype undefined + blen (unWithRefine wrelpa) - -instance (Foldable f, Typeable f, Typeable e) => Predicate (LenPfx 'I4 e) (f a) where - validate p a - | len > fromIntegral max' - = throwRefineOtherException (typeRep p) $ - "too long for given length prefix type: "<>tshow len<>" > "<>tshow max' - | otherwise = success - where - len = length a - max' = maxBound @(IRep 'U 'I4) - --- | TODO why safe -instance (BinaryCodec a, irep ~ IRep 'U size, itype ~ I 'U size e, Num irep, Integral irep, BinaryCodec itype) - => BinaryCodec (WithRefine 'Enforced (LenPfx size e) [a]) where - fromBin = do - len <- fromBin @itype - as <- replicateM (fromIntegral len) (fromBin @a) - return $ reallyUnsafeEnforce as - toBin wreas = do - toBin @itype $ fromIntegral $ length as - mapM_ (toBin @a) as - where as = unWithRefine wreas diff --git a/src/Binrep/Util.hs b/src/Binrep/Util.hs --- a/src/Binrep/Util.hs +++ b/src/Binrep/Util.hs @@ -1,7 +1,31 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + module Binrep.Util where +-- tshow import Data.Text qualified as Text import Data.Text ( Text ) +-- posIntToNat +import GHC.Exts ( Int(..), int2Word# ) +import GHC.Num.Natural ( Natural(..) ) + +-- natVal'' +import GHC.TypeNats ( KnownNat, natVal' ) +import GHC.Exts ( proxy#, Proxy# ) + tshow :: Show a => a -> Text tshow = Text.pack . show + +-- | Convert some 'Int' @i@ where @i >= 0@ to a 'Natural'. +-- +-- This is intended for wrapping the output of 'length' functions. +-- +-- underflows if you call it with a negative 'Int' :) +posIntToNat :: Int -> Natural +posIntToNat (I# i#) = NS (int2Word# i#) +{-# INLINE posIntToNat #-} + +natVal'' :: forall a. KnownNat a => Natural +natVal'' = natVal' (proxy# :: Proxy# a) +{-# INLINE natVal'' #-} diff --git a/src/Data/Aeson/Extra/SizedVector.hs b/src/Data/Aeson/Extra/SizedVector.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/SizedVector.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Aeson.Extra.SizedVector where + +import Data.Aeson +import Data.Vector.Generic.Sized.Internal qualified as VSI +import Data.Vector.Generic.Sized qualified as VS +import Data.Vector.Generic qualified as V +import GHC.TypeNats ( KnownNat ) + +instance ToJSON (v a) => ToJSON (VSI.Vector v n a) where + toJSON (VSI.Vector v) = toJSON v + toEncoding (VSI.Vector v) = toEncoding v +instance (FromJSON (v a), KnownNat n, V.Vector v a) => FromJSON (VSI.Vector v n a) where + parseJSON j = do + v <- parseJSON j + case VS.toSized v of + Nothing -> fail "TODO bad size" + Just v' -> return v' diff --git a/test/ArbitraryOrphans.hs b/test/ArbitraryOrphans.hs new file mode 100644 --- /dev/null +++ b/test/ArbitraryOrphans.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} + +module ArbitraryOrphans() where + +import Test.QuickCheck ( Arbitrary ) +import Binrep.Type.Int ( I(..), IRep ) + +-- | Machine integers steal their underlying representation's instance. +deriving via (IRep sign size) instance Arbitrary (IRep sign size) => Arbitrary (I sign size e) diff --git a/test/Binrep/Extra/HexByteStringSpec.hs b/test/Binrep/Extra/HexByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/Binrep/Extra/HexByteStringSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Extra.HexByteStringSpec ( spec ) where + +import Binrep.Extra.HexByteString +import Test.Hspec + +import Data.ByteString qualified as B +import Text.Megaparsec +import Data.Void ( Void ) + +megaparsecParseFromCharStream :: forall s a. (Stream s, Token s ~ Char) => Parsec Void s a -> s -> Maybe a +megaparsecParseFromCharStream parser text = parseMaybe parser text + +spec :: Spec +spec = do + let bs = B.pack + describe "parse" $ do + let p = megaparsecParseFromCharStream @String (parseHexByteString B.pack) + it "parses valid hex bytestrings" $ do + p "00" `shouldBe` Just (bs [0x00]) + p "FF" `shouldBe` Just (bs [0xFF]) + p "1234" `shouldBe` Just (bs [0x12, 0x34]) + p "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE]) + p "FFFFFFFF" `shouldBe` Just (B.replicate 4 0xFF) + p "12 34 AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD]) + it "fails to parse invalid hex bytestrings" $ do + p "-00" `shouldBe` Nothing + p "FG" `shouldBe` Nothing + it "fails to parse 0x prefix" $ do + p "1234" `shouldBe` Just (bs [0x12, 0x34]) + p "0x1234" `shouldBe` Nothing + describe "print" $ do + it "prints pretty hex bytestrings" $ do + let p = prettyHexByteString B.unpack + p (bs [0x5a, 0x7d]) `shouldBe` "5A 7D" + it "prints compact hex bytestrings" $ do + let pc = prettyHexByteStringCompact B.unpack + pc (bs [0xab, 0x25]) `shouldBe` "ab25" diff --git a/test/Binrep/LawsSpec.hs b/test/Binrep/LawsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Binrep/LawsSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.LawsSpec ( spec ) where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck.Instances.ByteString() +import Generic.Random +import Test.QuickCheck +import ArbitraryOrphans() + +import Binrep +import Binrep.Generic +import Binrep.Type.Int +import Binrep.Type.Common ( Endianness(..) ) +import Binrep.Type.ByteString +import Data.Word ( Word8 ) +import Data.ByteString qualified as B +import GHC.Generics ( Generic ) + +spec :: Spec +spec = do + prop "put is identity on ByteString" $ do + \(bs :: B.ByteString) -> runPut bs `shouldBe` bs + prop "parse-print roundtrip isomorphism (ByteString)" $ do + \(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, "") + +-------------------------------------------------------------------------------- + +type W1 = (I 'U 'I1 'LE) +type W2LE = (I 'U 'I2 'LE) +type W8BE = (I 'U 'I8 'BE) + +data D + = D01Bla Word8 W1 W8BE + | D23 W2LE B.ByteString -- dangerous bytestring, must be last + | DUnicode例 Word8 + | DSymbols_# + deriving stock (Generic, Eq, Show) +deriving via (GenericArbitraryU `AndShrinking` D) instance Arbitrary D + +dCfg :: Cfg (AsByteString 'C) +dCfg = Cfg { cSumTag = cSumTagNullTerm } + +instance BLen D where blen = blenGeneric dCfg +instance Put D where put = putGeneric dCfg +instance Get D where get = getGeneric dCfg diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}