diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +## 0.5.0 (2023-08-17) + * support GHC 9.2 - 9.6 + * extract generic serializing & parsing into separate library. yes, I wrote + generic generics. what are you going to do about it + * allow using different libraries for parsing and serializing (since I can't + decide) + * count-prefixed types use `Refined1`, currently in my refined fork + * refactor `Binrep.Type.Text`: users can now add extend to add their own + encodings + ## 0.3.1 (2022-08-28) * fix `Get [a]` instance diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,21 +4,24 @@ [gh-refined]: https://github.com/nikita-volkov/refined # binrep -binrep is a library for **precisely modelling binary schemas** and working with -them effectively and efficiently in Haskell. Here's why it's useful: +binrep is a Haskell library for *precisely modelling binary schemas*, especially +byte-oriented file formats, and working with them effectively and efficiently. +Here's why it's useful: - * **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 + * **Explicit:** Define Haskell data types with the binary schema "baked in". + Use highly parameterized binary representation primitives including + null-terminated data (e.g. C-style strings), Pascal-style data (length + prefixed), sized explicit-endian machine integers, null-padded data. Write + your own as needed. + * **Low boilerplate:** Straightforward schemas can leverage efficient generic + parsers and serializers with just a few lines. (See [Generic binary representation](#generic-binary-representation) for details.) - * **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. + * **Easy validation:** Use the [strongweak][gh-strongweak] library design + pattern to define an unvalidated data type for easy internal transformation, + and get validation code for free. + * **Performant:** Parsing and serialization is *extremely fast*, using + [flatparse][gh-flatparse] and [mason][gh-mason] respectively. An + experimental non-allocating serializer is also provided. ## Usage ### Dependencies @@ -139,3 +142,11 @@ 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. + +### flat +https://hackage.haskell.org/package/flat + +Cool, bit-oriented rather than byte-oriented. + +## License +Provided under the MIT license. See `LICENSE` for license text. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Gauge + +import Binrep +import Binrep.Generic +import Binrep.Type.NullTerminated +import Data.ByteString qualified as B +import Refined + +import GHC.Generics ( Generic ) +import Data.Word + +{- +data X = X Word8 Word16 Word8 + deriving stock (Generic) + +instance Put X where put = putGeneric c +instance Put' X where put' = put'Generic +instance BLen X where blen _ = 4 +-} + +data X3 + = X31 Word8 + | X32 Word8 + | X33 Word8 (NullTerminated B.ByteString) X3 + deriving stock (Generic) + +instance BLen X3 where blen = blenGenericSum cDef +instance Put X3 where put = putGenericSum cDef + +x33 :: X3 +x33 = + X33 001 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X33 002 $$(refineTH "hi, cstring here") + $ X33 003 $$(refineTH "hi, cstring here") + $ X33 004 $$(refineTH "hi, cstring here") + $ X33 005 $$(refineTH "hi, cstring here") + $ X33 006 $$(refineTH "hi, cstring here") + $ X33 007 $$(refineTH "hi, cstring here") + $ X32 008 + +main :: IO () +main = defaultMain + [ bgroup "tiny" + [ bench "put" $ whnf Binrep.runPut x33 + ] + ] diff --git a/binrep.cabal b/binrep.cabal --- a/binrep.cabal +++ b/binrep.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: binrep -version: 0.3.1 +version: 0.5.0 synopsis: Encode precise binary representations directly in types description: Please see README.md. category: Data, Serialization @@ -17,7 +17,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC ==9.2.4 + GHC ==9.4.4 extra-source-files: README.md CHANGELOG.md @@ -34,96 +34,81 @@ library exposed-modules: Binrep - Binrep.BLen - Binrep.BLen.Internal.AsBLen - Binrep.Example - Binrep.Example.FileTable - Binrep.Example.Tar - Binrep.Example.Tiff - Binrep.Example.Wav + Binrep.BLen.Simple + Binrep.CBLen + Binrep.CBLen.Generic 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.Get.Flatparse + Binrep.Put.Bytezap + Binrep.Put.Mason 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.NullTerminated + Binrep.Type.Prefix + Binrep.Type.Prefix.Count + Binrep.Type.Prefix.Size Binrep.Type.Sized Binrep.Type.Text - Binrep.Type.Varint - Binrep.Type.Vector + Binrep.Type.Text.Encoding.Ascii + Binrep.Type.Text.Encoding.ShiftJis + Binrep.Type.Text.Encoding.Utf16 + Binrep.Type.Text.Encoding.Utf32 + Binrep.Type.Text.Encoding.Utf8 + Binrep.Type.Text.Internal + Binrep.Type.Thin Binrep.Util + Binrep.Util.Class + Binrep.Util.Generic + Binrep.Via + Bytezap + Bytezap.Bytes + Bytezap.Class + Bytezap.Int + Bytezap.Poke.Bytes + Bytezap.Poke.Int + Bytezap.Text Data.Aeson.Extra.SizedVector - Haskpatch.Format.Bps - Haskpatch.Format.Vcdiff - Util.Generic + Util.TypeNats other-modules: Paths_binrep hs-source-dirs: src default-extensions: - EmptyCase LambdaCase - InstanceSigs - BangPatterns - ExplicitNamespaces - DerivingStrategies + NoStarIsType DerivingVia - StandaloneDeriving DeriveAnyClass - DeriveGeneric - DeriveDataTypeable - DeriveFunctor - DeriveFoldable - DeriveTraversable - DeriveLift - FlexibleContexts - FlexibleInstances - MultiParamTypeClasses GADTs - PolyKinds RoleAnnotations - RankNTypes - TypeApplications DefaultSignatures TypeFamilies DataKinds MagicHash - ImportQualifiedPost - StandaloneKindSignatures - BinaryLiterals - ScopedTypeVariables - TypeOperators ghc-options: -Wall build-depends: - aeson ==2.0.* + aeson >=2.0 && <2.2 , base >=4.14 && <5 - , bytestring ==0.11.* - , either >=5.0.1.1 && <5.1 - , flatparse >=0.3.5.0 && <0.4 + , bytestring >=0.11 && <0.13 + , deepseq >=1.4.6.1 && <1.6 + , flatparse >=0.4.0.1 && <0.6 + , generic-data-functions >=0.2.0 && <0.3 , mason >=0.2.5 && <0.3 - , megaparsec >=9.2.0 && <9.3 - , refined ==0.7.* - , strongweak >=0.3.1 && <0.4 - , text >=1.2 && <2.1 - , vector >=0.12.3.1 && <0.13 + , megaparsec >=9.2.0 && <9.5.0 + , parser-combinators >=1.3.0 && <1.4 + , refined1 ==0.9.* + , strongweak >=0.6.0 && <0.7 + , text >=1.2.5.0 && <2.1 + , vector >=0.12.3.1 && <0.14 , vector-sized >=1.5.0 && <1.6 + default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU build-depends: text-icu >=0.7.0.0 && <0.9 - default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 @@ -136,61 +121,83 @@ hs-source-dirs: test default-extensions: - EmptyCase LambdaCase - InstanceSigs - BangPatterns - ExplicitNamespaces - DerivingStrategies + NoStarIsType DerivingVia - StandaloneDeriving DeriveAnyClass - DeriveGeneric - DeriveDataTypeable - DeriveFunctor - DeriveFoldable - DeriveTraversable - DeriveLift - FlexibleContexts - FlexibleInstances - MultiParamTypeClasses GADTs - PolyKinds RoleAnnotations - RankNTypes - TypeApplications DefaultSignatures TypeFamilies DataKinds MagicHash - ImportQualifiedPost - StandaloneKindSignatures - BinaryLiterals - ScopedTypeVariables - TypeOperators ghc-options: -Wall build-tool-depends: - hspec-discover:hspec-discover >=2.7 && <2.10 + hspec-discover:hspec-discover >=2.7 && <2.12 build-depends: QuickCheck >=2.14.2 && <2.15 - , aeson ==2.0.* + , aeson >=2.0 && <2.2 , base >=4.14 && <5 , binrep - , bytestring ==0.11.* - , either >=5.0.1.1 && <5.1 - , flatparse >=0.3.5.0 && <0.4 + , bytestring >=0.11 && <0.13 + , deepseq >=1.4.6.1 && <1.6 + , flatparse >=0.4.0.1 && <0.6 + , generic-data-functions >=0.2.0 && <0.3 , generic-random >=1.5.0.1 && <1.6 - , hspec >=2.7 && <2.10 + , hspec >=2.7 && <2.12 , mason >=0.2.5 && <0.3 - , megaparsec >=9.2.0 && <9.3 + , megaparsec >=9.2.0 && <9.5.0 + , parser-combinators >=1.3.0 && <1.4 , quickcheck-instances >=0.3.26 && <0.4 - , refined ==0.7.* - , strongweak >=0.3.1 && <0.4 - , text >=1.2 && <2.1 - , vector >=0.12.3.1 && <0.13 + , refined1 ==0.9.* + , strongweak >=0.6.0 && <0.7 + , text >=1.2.5.0 && <2.1 + , vector >=0.12.3.1 && <0.14 , vector-sized >=1.5.0 && <1.6 + default-language: GHC2021 if flag(icu) cpp-options: -DHAVE_ICU build-depends: text-icu >=0.7.0.0 && <0.9 - default-language: Haskell2010 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_binrep + hs-source-dirs: + bench + default-extensions: + LambdaCase + NoStarIsType + DerivingVia + DeriveAnyClass + GADTs + RoleAnnotations + DefaultSignatures + TypeFamilies + DataKinds + MagicHash + ghc-options: -Wall -O2 + build-depends: + aeson >=2.0 && <2.2 + , base >=4.14 && <5 + , binrep + , bytestring >=0.11 && <0.13 + , deepseq >=1.4.6.1 && <1.6 + , flatparse >=0.4.0.1 && <0.6 + , gauge + , generic-data-functions >=0.2.0 && <0.3 + , mason >=0.2.5 && <0.3 + , megaparsec >=9.2.0 && <9.5.0 + , parser-combinators >=1.3.0 && <1.4 + , refined1 ==0.9.* + , strongweak >=0.6.0 && <0.7 + , text >=1.2.5.0 && <2.1 + , vector >=0.12.3.1 && <0.14 + , vector-sized >=1.5.0 && <1.6 + default-language: GHC2021 + if flag(icu) + cpp-options: -DHAVE_ICU + build-depends: + text-icu >=0.7.0.0 && <0.9 diff --git a/src/Binrep.hs b/src/Binrep.hs --- a/src/Binrep.hs +++ b/src/Binrep.hs @@ -1,26 +1,18 @@ -{- | Main end-user binrep module bundling most functionality. - -Generics are bundled together in 'Binrep.Generic'. --} - module Binrep - ( module Binrep.BLen - , module Binrep.Put - , module Binrep.Get - - -- * Extras - , blenViaPut + ( module Binrep.CBLen + , module Binrep.BLen.Simple + , module Binrep.Put.Bytezap + , module Binrep.Get.Flatparse ) where -import Binrep.BLen -import Binrep.Put -import Binrep.Get +import Binrep.CBLen +import Binrep.BLen.Simple +import Binrep.Put.Bytezap +import Binrep.Get.Flatparse --- | The length in bytes of a 'Put'-able type is the length of the serialized --- term. --- --- Do not use this in 'BLen' instances. It's intended as a proof, and --- potentially for testing purposes. Calculating length in bytes shouldn't --- involve serializing (it should be fast and use minimal memory). -blenViaPut :: Put a => a -> BLenT -blenViaPut = blen . runPut +{- TODO + * binrep is its own ecosystem where explicitness and correctness wins over + all. There are no binrep instances for 'Data.Void.Void' or 'GHC.Generics.V1' + because these can't be binrepped; rather than providing an absurd, possibly + convenient instance, we emit a type error for their attempted use. +-} diff --git a/src/Binrep/BLen.hs b/src/Binrep/BLen.hs deleted file mode 100644 --- a/src/Binrep/BLen.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- for CBLen - -module Binrep.BLen - ( module Binrep.BLen - , module Binrep.BLen.Internal.AsBLen - ) where - -import Binrep.BLen.Internal.AsBLen -import Binrep.Util ( natVal'' ) - -import GHC.TypeLits - -import Data.ByteString qualified as B - -import Data.Word -import Data.Int - -import Data.Void ( Void, absurd ) - -type BLenT = Int - -{- | The length in bytes of a value of the given type can be known on the cheap - e.g. by reading a length field, or using compile time information. - -Some binary representation building blocks require the notion of length in bytes -in order to handle, e.g. null padding. One may always obtain this by serializing -the value, then reading out the length of the output bytestring. But in most -cases, we can be much more efficient. - - * Certain primitives have a size known at compile time, irrelevant of the - value. A 'Word64' is always 8 bytes; some data null-padded to @n@ bytes is - exactly @n@ bytes long. - * For simple ADTs, it's often possible to calculate length in bytes via - pattern matching and some numeric operations. Very little actual work. - -This type class enables each type to implement its own efficient method of byte -length calculation. Aim to write something that plainly feels more efficient -than full serialization. If that doesn't feel possible, you might be working -with a type ill-suited for binary representation. - -A thought: Some instances could be improved by reifying 'CBLen'. But it would -mess up all the deriving, and it feels like too minor an improvement to be -worthwhile supporting, writing a bunch of newtype wrappers, etc. --} -class BLen a where - -- | The length in bytes of the serialized value. - -- - -- The default implementation reifies the constant length for the type. If a - -- type-wide constant length is not defined, it will fail at compile time. - blen :: a -> BLenT - default blen :: KnownNat (CBLen a) => a -> BLenT - blen _ = cblen @a - - -- | The length in bytes of any value of the given type is constant. - -- - -- Many binary representation primitives are constant, or may be designed to - -- "store" their size in their type. This is a stronger statement about - -- their length than just 'blen'. - -- - -- This is now an associated type family of the 'BLen' type class in hopes - -- of simplifying the binrep framework. - type CBLen a :: Natural - type CBLen a = - TypeError - ( 'Text "No CBLen associated family instance defined for " - ':<>: 'ShowType a - ) - -typeNatToBLen :: forall n. KnownNat n => BLenT -typeNatToBLen = natToBLen $ natVal'' @n -{-# INLINE typeNatToBLen #-} - --- | 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 #-} - --- | Impossible to put a byte length to 'Void'. -instance BLen Void where - blen = absurd - --- | @O(n)@ -instance BLen a => BLen [a] where - blen = sum . map blen - -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 - -instance BLen Word8 where type CBLen Word8 = 1 -instance BLen Int8 where type CBLen Int8 = 1 -instance BLen Word16 where type CBLen Word16 = 2 -instance BLen Int16 where type CBLen Int16 = 2 -instance BLen Word32 where type CBLen Word32 = 4 -instance BLen Int32 where type CBLen Int32 = 4 -instance BLen Word64 where type CBLen Word64 = 8 -instance BLen Int64 where type CBLen Int64 = 8 - --------------------------------------------------------------------------------- - --- | Newtype wrapper for defining 'BLen' instances which are allowed to assume --- the existence of a valid 'CBLen' family instance. -newtype WithCBLen a = WithCBLen { unWithCBLen :: a } - -instance KnownNat (CBLen a) => BLen (WithCBLen [a]) where - blen (WithCBLen l) = cblen @a * length l -instance KnownNat (CBLen a + CBLen b) => BLen (WithCBLen (a, b)) where - type CBLen (WithCBLen (a, b)) = CBLen a + CBLen b diff --git a/src/Binrep/BLen/Internal/AsBLen.hs b/src/Binrep/BLen/Internal/AsBLen.hs deleted file mode 100644 --- a/src/Binrep/BLen/Internal/AsBLen.hs +++ /dev/null @@ -1,65 +0,0 @@ -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/BLen/Simple.hs b/src/Binrep/BLen/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/BLen/Simple.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE UndecidableInstances #-} -- for 'CBLenly', 'TypeError' +{-# LANGUAGE AllowAmbiguousTypes #-} -- for 'cblen', 'natValInt' + +{- | Byte length as a simple pure function, no bells or whistles. + +Non-reallocating serializers like store, bytezap or ptr-poker request the +expected total byte length when serializing. Thus, they need some way to measure +byte length *before* serializing. This is that. + +It should be very efficient to calculate serialized byte length for most +binrep-compatible Haskell types. If it isn't, consider whether the +representation is appropriate for binrep. +-} + +module Binrep.BLen.Simple where + +import Binrep.CBLen +import GHC.TypeNats +import Util.TypeNats ( natValInt ) + +import Binrep.Util.Class +import GHC.TypeLits ( TypeError ) + +import Data.Void +import Data.ByteString qualified as B +import Data.Word +import Data.Int +import Bytezap ( Write(..) ) + +import Data.Monoid ( Sum(..) ) +import GHC.Generics +import Generic.Data.Function.FoldMap +import Generic.Data.Rep.Assert +import Generic.Data.Function.Common + +class BLen a where blen :: a -> Int + +-- newtype sum monoid for generic foldMap +newtype BLen' a = BLen' { getBLen' :: a } + deriving (Semigroup, Monoid) via Sum a + +instance GenericFoldMap (BLen' Int) where + type GenericFoldMapC (BLen' Int) a = BLen a + genericFoldMapF = BLen' . blen + +-- | Measure the byte length of a term of the non-sum type @a@ via its 'Generic' +-- instance. +blenGenericNonSum + :: forall {cd} {f} {asserts} a + . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum (BLen' Int) f + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + => a -> Int +blenGenericNonSum = getBLen' . genericFoldMapNonSum @asserts + +-- | Measure the byte length of a term of the sum type @a@ via its 'Generic' +-- instance. +-- +-- You must provide a function to obtain the byte length for the prefix tag, via +-- inspecting the reified constructor names. This is regrettably inefficient. +-- Alas. Do write your own instance if you want better performance! +blenGenericSum + :: forall {cd} {f} {asserts} a + . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly (BLen' Int) f + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + => (String -> Int) -> a -> Int +blenGenericSum f = getBLen' . genericFoldMapSum @'SumOnly @asserts (BLen' <$> f) + +instance TypeError ENoEmpty => BLen Void where blen = undefined +instance TypeError ENoSum => BLen (Either a b) where blen = undefined + +instance BLen Write where + {-# INLINE blen #-} + blen = writeSize + +-- | Unit type has length 0. +instance BLen () where + {-# INLINE blen #-} + blen () = 0 + +-- | Sum tuples. +instance (BLen l, BLen r) => BLen (l, r) where + {-# INLINE blen #-} + blen (l, r) = blen l + blen r + +-- | _O(n)_ Sum the length of each element of a list. +instance BLen a => BLen [a] where + {-# INLINE blen #-} + blen = sum . map blen + +-- | Length of a bytestring is fairly obvious. +instance BLen B.ByteString where + {-# INLINE blen #-} + blen = B.length + +-- Machine integers have a constant byte length. +deriving via CBLenly Word8 instance BLen Word8 +deriving via CBLenly Int8 instance BLen Int8 +deriving via CBLenly Word16 instance BLen Word16 +deriving via CBLenly Int16 instance BLen Int16 +deriving via CBLenly Word32 instance BLen Word32 +deriving via CBLenly Int32 instance BLen Int32 +deriving via CBLenly Word64 instance BLen Word64 +deriving via CBLenly Int64 instance BLen Int64 + +-------------------------------------------------------------------------------- + +-- | Deriving via wrapper for types which may derive a 'BLen' instance through +-- an existing 'IsCBLen' instance. +-- +-- Examples of such types include machine integers, and explicitly-sized types +-- (e.g. "Binrep.Type.Sized"). +newtype CBLenly a = CBLenly { unCBLenly :: a } +instance KnownNat (CBLen a) => BLen (CBLenly a) where + {-# INLINE blen #-} + blen _ = cblen @a + +-- | Reify a type's constant byte length to the term level. +cblen :: forall a n. (n ~ CBLen a, KnownNat n) => Int +cblen = natValInt @n +{-# INLINE cblen #-} diff --git a/src/Binrep/CBLen.hs b/src/Binrep/CBLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/CBLen.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UndecidableInstances #-} -- for 'WithCBLen' +{-# LANGUAGE AllowAmbiguousTypes #-} -- for 'cblen' + +module Binrep.CBLen where + +import GHC.TypeNats +import Data.Word +import Data.Int + +class IsCBLen a where type CBLen a :: Natural + +instance IsCBLen () where type CBLen () = 0 +instance (IsCBLen l, IsCBLen r) => IsCBLen (l, r) where + type CBLen (l, r) = CBLen l + CBLen r + +instance IsCBLen Word8 where type CBLen Word8 = 2^0 +instance IsCBLen Int8 where type CBLen Int8 = 2^0 +instance IsCBLen Word16 where type CBLen Word16 = 2^1 +instance IsCBLen Int16 where type CBLen Int16 = 2^1 +instance IsCBLen Word32 where type CBLen Word32 = 2^2 +instance IsCBLen Int32 where type CBLen Int32 = 2^2 +instance IsCBLen Word64 where type CBLen Word64 = 2^3 +instance IsCBLen Int64 where type CBLen Int64 = 2^3 diff --git a/src/Binrep/CBLen/Generic.hs b/src/Binrep/CBLen/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/CBLen/Generic.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE UndecidableInstances #-} -- hugely unsafe module + +{- | _Experimental._ Generically derive 'CBLen' type family instances. + +A type having a valid 'CBLen' instance usually indicates one of the following: + + * it's a primitive, or extremely simple + * it holds size information in its type + * it's constructed from other constant byte length types + +The first two cases must be handled manually. The third case is where Haskell +generics excel, and the one this module targets. + +You can (attempt to) derive a 'CBLen' type family instance generically for a +type via + + instance BLen a where type CBLen a = CBLenGeneric w a + +As with deriving @BLen@ generically, you must provide the type used to store the +sum tag for sum types. + +Then try using it. Hopefully it works, or you get a useful type error. If not, +sorry. I don't have much faith in this code. +-} + +module Binrep.CBLen.Generic where + +import Binrep.CBLen +import Binrep.Util.Class + +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 ENoEmpty + GCBLen w (M1 _ _ f) = GCBLen w f + +--type family GCBLenSum w (f :: k -> Type) :: Maybe Natural where +type family GCBLenSum w (f :: k -> Type) where + GCBLenSum w (C1 ('MetaCons name _ _) f) = JustX (GCBLen w f) name + GCBLenSum w (l :+: r) = MaybeEq (GCBLenSum w l) (GCBLenSum w r) + +type family MaybeEq a b where + MaybeEq (JustX n nName) (JustX m _) = If (n == m) (JustX n nName) NothingX + MaybeEq _ _ = NothingX + +-- | I don't know how to pattern match in types without writing type families. +type family GCBLenCaseMaybe a where + GCBLenCaseMaybe (JustX n _) = n + GCBLenCaseMaybe NothingX = + TypeError + ( 'Text "Two constructors didn't have equal constant size." + ':$$: 'Text "Sry dunno how to thread errors thru LOL" + ) + +-- TODO rewrite this stuff to thread error info through! +data JustX a b +data NothingX + diff --git a/src/Binrep/Example.hs b/src/Binrep/Example.hs deleted file mode 100644 --- a/src/Binrep/Example.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# 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 ) - -import Data.Void ( Void ) - -data DV - deriving stock (Generic, Data) - --- Disallowed. No binrepping void datatypes. -{- -instance BLen DV where blen = blenGeneric BR.cNoSum -instance Put DV where put = putGeneric BR.cNoSum -instance Get DV where get = getGeneric BR.cNoSum --} - -data DU = DU - deriving stock (Generic, Data, Show, Eq) - ---instance BLen DU where blen = blenGeneric BR.cNoSum -instance BLen DU where type CBLen DU = CBLenGeneric Void DU -instance Put DU where put = putGeneric cNoSum -instance Get DU where get = getGeneric cNoSum - -data DSS = DSS - { dss1 :: I 'U 'I1 'LE - , 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 cNoSum ---instance BLen DSS where type CBLen DSS = CBLenGeneric Void DSS -instance Put DSS where put = putGeneric cNoSum -instance Get DSS where get = getGeneric cNoSum - -data DCS = DCS1 {- DSS -} | DCS2 | DCS3 | DCS4 | DCS5 - deriving stock (Generic, Data, Show, Eq) - -type BrSumDCS = I 'U 'I1 'LE -brCfgDCS :: BR.Cfg BrSumDCS -brCfgDCS = BR.cfg $ BR.cSumTagHex $ drop 3 - ---instance BLen DCS where blen = BR.blenGeneric brCfgDCS -instance BLen DCS where type CBLen DCS = CBLenGeneric BrSumDCS DCS -instance Put DCS where put = putGeneric brCfgDCS -instance Get DCS where get = getGeneric brCfgDCS - -data DX = DX DU - deriving stock (Generic, Data, Show, Eq) - ---instance BLen DX where blen = blenGeneric brCfgNoSum -instance BLen DX where type CBLen DX = CBLenGeneric Void DX -instance Put DX where put = putGeneric cNoSum -instance Get DX where get = getGeneric cNoSum diff --git a/src/Binrep/Example/FileTable.hs b/src/Binrep/Example/FileTable.hs deleted file mode 100644 --- a/src/Binrep/Example/FileTable.hs +++ /dev/null @@ -1,105 +0,0 @@ -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 deleted file mode 100644 --- a/src/Binrep/Example/Tar.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Binrep.Example.Tar where - -import Binrep -import Binrep.Generic -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 - --- | 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) - -instance KnownNat n => BLen (TarNat n) where - type CBLen (TarNat n) = n - --- | No need to check for underflow etc. as TarNat guarantees good sizing. -instance KnownNat n => Put (TarNat n) where - 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 -> eBase $ EExpectedByte 0x00 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 cNoSum -instance Put Tar where put = putGeneric cNoSum -instance Get Tar where get = getGeneric cNoSum diff --git a/src/Binrep/Example/Tiff.hs b/src/Binrep/Example/Tiff.hs deleted file mode 100644 --- a/src/Binrep/Example/Tiff.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} - -module Binrep.Example.Tiff where - -import Binrep -import Binrep.Generic -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 - -data Tiff where - Tiff :: (Put (I 'U 'I4 end), bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, KnownNat (Length bs)) => TiffBody end -> Tiff - -instance Show Tiff where - show (Tiff body) = "Tiff " <> show body - -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 ~ MagicBytes (TiffMagic end), KnownNat (Length bs)) => BLen (TiffBody end) where - blen = blenGeneric cNoSum -instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Put irep) => Put (TiffBody end) where - put = putGeneric cNoSum -instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Get irep) => Get (TiffBody end) where - get = getGeneric cNoSum - -instance BLen Tiff where - blen (Tiff body) = blen body - -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 deleted file mode 100644 --- a/src/Binrep/Example/Wav.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Binrep.Example.Wav where - -import Binrep -import Binrep.Generic -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.Int -import Binrep.Type.Magic - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -type End = 'LE -type W32 = I 'U 'I4 End -type W16 = I 'U 'I2 End - -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 cNoSum -instance Put WavHeader where put = putGeneric cNoSum -instance Get WavHeader where get = getGeneric cNoSum diff --git a/src/Binrep/Extra/HexByteString.hs b/src/Binrep/Extra/HexByteString.hs --- a/src/Binrep/Extra/HexByteString.hs +++ b/src/Binrep/Extra/HexByteString.hs @@ -76,7 +76,7 @@ parseHexByte = do c1 <- MC.hexDigitChar c2 <- MC.hexDigitChar - return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2) + pure $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2) -- | Pretty print to default format @00 12 AB FF@: space between each byte, all -- caps. diff --git a/src/Binrep/Generic.hs b/src/Binrep/Generic.hs --- a/src/Binrep/Generic.hs +++ b/src/Binrep/Generic.hs @@ -1,79 +1,16 @@ --- | Derive 'BLen', 'Put', 'Get' and 'CBLen' instances generically. - -module Binrep.Generic - ( Cfg(..), cfg - , cSumTagHex, cSumTagNullTerm, cDef - , cNoSum, EDerivedSumInstanceWithNonSumCfg(..) - , 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 +module Binrep.Generic where -import Binrep.Type.ByteString ( AsByteString, Rep(..) ) -import Refined.Unsafe ( reallyUnsafeRefine ) +import Binrep.Type.NullTerminated +import Data.ByteString qualified as B import Data.Text qualified as Text import Data.Text.Encoding qualified as Text - -import Numeric ( readHex ) - -import Data.Void ( Void ) -import Control.Exception ( Exception, throw ) - -import Binrep.Util ( tshow ) - -cfg :: (Eq a, Show a) => (String -> a) -> Cfg a -cfg f = Cfg { cSumTag = f, cSumTagEq = (==), cSumTagShow = tshow } - --- | Obtain the tag for a sum type value by applying a function to the --- constructor name, and reading the result as a hexadecimal number. -cSumTagHex :: forall a. Integral a => (String -> String) -> String -> a -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??)" +import Refined.Unsafe --- | Obtain the tag for a sum type value using the constructor name directly --- (with a null terminator). +-- | Turn a constructor name into a prefix tag by adding a null terminator. -- --- This is probably not what you want in a binary representation, but it's safe --- and may be useful for debugging. +-- Not common in binary data representations, but safe and useful for debugging. -- -- The refine force is safe under the assumption that Haskell constructor names --- are UTF-8 with no null bytes allowed. I haven't confirmed that, but I'm --- fairly certain. -cSumTagNullTerm :: String -> AsByteString 'C -cSumTagNullTerm = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack - --- | Default generic derivation configuration, using 'cSumTagNullTerm'. -cDef :: Cfg (AsByteString 'C) -cDef = cfg cSumTagNullTerm - --- | Special generic derivation configuration you may use for non-sum data --- types. --- --- When generically deriving binrep instances for a non-sum type, you may like --- to ignore sum tag handling. You could use 'cDef', but this will silently --- change behaviour if your type becomes a sum type. This configuration will --- generate clear runtime errors when used with a sum type. --- --- By selecting 'Void' for the sum tag type, consumption actions (serializing, --- getting length in bytes) will runtime error, while generation actions --- (parsing) will hit the 'Void' instance first and always safely error out. -cNoSum :: Cfg Void -cNoSum = cfg $ \_ -> throw EDerivedSumInstanceWithNonSumCfg - --- This indirection enables us to test for this precise exception being thrown --- in an incorrect configuration! Awesome! -data EDerivedSumInstanceWithNonSumCfg = EDerivedSumInstanceWithNonSumCfg -instance Show EDerivedSumInstanceWithNonSumCfg where - show EDerivedSumInstanceWithNonSumCfg = - "Binrep.Generic.cNoSum: non-sum generic derivation configuration used with a sum type" -instance Exception EDerivedSumInstanceWithNonSumCfg +-- are UTF-8 with no null bytes allowed. Fairly certain that's true. +nullTermCstrPfxTag :: String -> NullTerminated B.ByteString +nullTermCstrPfxTag = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack diff --git a/src/Binrep/Generic/BLen.hs b/src/Binrep/Generic/BLen.hs deleted file mode 100644 --- a/src/Binrep/Generic/BLen.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( - -module Binrep.Generic.BLen where - -import GHC.Generics -import GHC.TypeLits ( TypeError ) - -import Binrep.BLen -import Binrep.Generic.Internal -import Util.Generic - -blenGeneric :: (Generic a, GBLen (Rep a), BLen w) => Cfg w -> a -> BLenT -blenGeneric cfg = gblen cfg . from - -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 deleted file mode 100644 --- a/src/Binrep/Generic/CBLen.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -{- | _Experimental._ Generically derive 'CBLen' type family instances. - -A type having a valid 'CBLen' instance usually indicates one of the following: - - * it's a primitive, or extremely simple - * it holds size information in its type - * it's constructed from other constant byte length types - -The first two cases must be handled manually. The third case is where Haskell -generics excel, and the one this module targets. - -You can (attempt to) derive a 'CBLen' type family instance generically for a -type via - - instance BLen a where type CBLen a = CBLenGeneric w a - -As with deriving @BLen@ generically, you must provide the type used to store the -sum tag for sum types. - -Then try using it. Hopefully it works, or you get a useful type error. If not, -sorry. I don't have much faith in this code. --} - -module Binrep.Generic.CBLen where - -import Binrep.BLen -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 deleted file mode 100644 --- a/src/Binrep/Generic/Get.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# 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 Util.Generic - -import FlatParse.Basic qualified as FP -import Control.Applicative ( (<|>) ) - -import Numeric.Natural - -getGeneric :: (Generic a, GGetD (Rep a), Get w) => Cfg w -> Getter a -getGeneric cfg = to <$> ggetD cfg - -class GGetD f where - ggetD :: Get w => Cfg w -> Getter (f a) - -instance (GGetC f, Datatype d) => GGetD (D1 d f) where - ggetD cfg = M1 <$> ggetC cfg (datatypeName' @d) - -class GGetC f where - ggetC :: Get w => Cfg w -> String -> Getter (f a) - --- | Refuse to derive instance for empty data types. -instance TypeError GErrRefuseVoid => GGetC V1 where - ggetC = undefined - --- | TODO: Non-sum data types. -instance (GGetS f, Constructor c) => GGetC (C1 c f) where - ggetC cfg dStr = (M1 . snd) <$> ggetS cfg dStr (conName' @c) 0 - -class GGetS f where - ggetS :: Get w => Cfg w -> String -> String -> Natural -> Getter (Natural, (f a)) - --- | The empty constructor trivially succeeds without parsing anything. -instance GGetS U1 where - ggetS _ _ _ fIdx = pure (fIdx, U1) - -instance (GGetS l, GGetS r) => GGetS (l :*: r) where - ggetS cfg dStr cStr fIdx = do - (fIdx', l) <- ggetS cfg dStr cStr fIdx - (fIdx'', r) <- ggetS cfg dStr cStr (fIdx'+1) - pure (fIdx'', l :*: r) - -instance (Get a, Selector s) => GGetS (S1 s (Rec0 a)) where - ggetS _ dStr cStr fIdx = do - a <- getEWrap $ EGeneric dStr . EGenericField cStr sStr fIdx - pure (fIdx, M1 (K1 a)) - where - sStr = selName'' @s - --------------------------------------------------------------------------------- - --- | Constructor sums are differentiated by a prefix tag. -instance GGetCSum (l :+: r) => GGetC (l :+: r) where - ggetC cfg dStr = do - tag <- getEWrap $ EGeneric dStr . EGenericSum . EGenericSumTag - case ggetCSum cfg dStr tag of - Just parser -> parser - Nothing -> do - let tagPretty = cSumTagShow cfg $ tag - FP.err $ EGeneric dStr $ EGenericSum $ EGenericSumTagNoMatch [] tagPretty - --- | TODO: Want to return an @Either [(String, Text)]@ indicating the --- constructors and their expected tags tested, but needs fiddling (can't use --- 'Alternative'). Pretty minor, but Aeson does it and it's nice. -class GGetCSum f where - ggetCSum :: Get w => Cfg w -> String -> w -> Maybe (Getter (f a)) - -instance (GGetCSum l, GGetCSum r) => GGetCSum (l :+: r) where - ggetCSum cfg dStr tag = l <|> r - where - l = fmap L1 <$> ggetCSum cfg dStr tag - r = fmap R1 <$> ggetCSum cfg dStr tag - -instance (GGetS f, Constructor c) => GGetCSum (C1 c f) where - ggetCSum cfg dStr tag = - let cStr = conName' @c - cTag = (cSumTag cfg) cStr - in if (cSumTagEq cfg) tag cTag - then Just ((M1 . snd) <$> ggetS cfg dStr cStr 0) - else Nothing diff --git a/src/Binrep/Generic/Internal.hs b/src/Binrep/Generic/Internal.hs deleted file mode 100644 --- a/src/Binrep/Generic/Internal.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Binrep.Generic.Internal where - -import GHC.TypeLits -import Data.Text ( Text ) - -data Cfg a = Cfg - { cSumTag :: String -> a - -- ^ How to turn a constructor name into a byte tag. - - , cSumTagEq :: a -> a -> Bool - , cSumTagShow :: a -> Text - } - --- | Common type error string for when GHC attempts to derive an binrep instance --- for a (the?) void datatype @V1@. -type GErrRefuseVoid = - 'Text "Refusing to derive binary representation for void datatype" diff --git a/src/Binrep/Generic/Put.hs b/src/Binrep/Generic/Put.hs deleted file mode 100644 --- a/src/Binrep/Generic/Put.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( - -module Binrep.Generic.Put where - -import GHC.Generics -import GHC.TypeLits ( TypeError ) - -import Binrep.Put -import Binrep.Generic.Internal -import Util.Generic - -putGeneric :: (Generic a, GPut (Rep a), Put w) => Cfg w -> a -> Builder -putGeneric cfg = gput cfg . from - -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 deleted file mode 100644 --- a/src/Binrep/Get.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} - -module Binrep.Get - ( Getter, Get(..), runGet, runGetter - , E(..), EBase(..), EGeneric(..), EGenericSum(..) - , eBase - , getEWrap, getEBase - , cutEBase - , GetWith(..), runGetWith - ) where - -import FlatParse.Basic qualified as FP - -import Data.ByteString qualified as B - -import GHC.Exts ( TYPE, type LiftedRep ) - -import Data.Word -import Data.Int -import Data.Void ( Void ) - -import GHC.Generics ( Generic ) - -import Data.Text ( Text ) - -import Binrep.BLen ( BLenT ) - -import Numeric.Natural - -type Getter a = FP.Parser E a - -data E - = EBase EBase - - | EGeneric String {- ^ datatype name -} EGeneric - - deriving stock (Eq, Show, Generic) - -eBase :: EBase -> Getter a -eBase = FP.err . EBase - --- | TODO confirm correct operation (error combination) -getEWrap :: Get a => (E -> E) -> Getter a -getEWrap f = FP.cutting get (f $ EBase EFail) (\e _ -> f e) - -getEBase :: Get a => EBase -> Getter a -getEBase = FP.cut get . EBase - -cutEBase :: Getter a -> EBase -> Getter a -cutEBase f e = FP.cut f $ EBase e - -data EBase - = ENoVoid - | EFail - - | EExpectedByte Word8 Word8 - -- ^ expected first, got second - - | EOverlong BLenT BLenT - -- ^ expected first, got second - - | EExpected B.ByteString B.ByteString - -- ^ expected first, got second - - | EFailNamed String - -- ^ known fail - - | EFailParse String B.ByteString Word8 - -- ^ parse fail (where you parse a larger object, then a smaller one in it) - - | ERanOut Natural - -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0) - - deriving stock (Eq, Show, Generic) - -data EGeneric - = EGenericSum EGenericSum - | EGenericField String (Maybe String) Natural E - deriving stock (Eq, Show, Generic) - -data EGenericSum - = EGenericSumTag E - | EGenericSumTagNoMatch [String] Text - deriving stock (Eq, Show, Generic) - -class Get a where - -- | Parse from binary. - get :: Getter a - -runGet :: Get a => B.ByteString -> Either E (a, B.ByteString) -runGet = runGetter get - -runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString) -runGetter g bs = case FP.runParser g bs of - FP.OK a bs' -> Right (a, bs') - FP.Fail -> Left $ EBase EFail - FP.Err e -> Left e - --- | Impossible to parse 'Void'. -instance Get Void where - get = eBase ENoVoid - --- | Parse heterogeneous lists in order. No length indicator, so either fails or --- succeeds by reaching EOF. Probably not what you usually want, but sometimes --- used at the "top" of binary formats. -instance Get a => Get [a] where - get = go - where - go = do - FP.withOption FP.eof (\() -> pure []) $ do - a <- get - as <- go - pure $ a : 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 = cutEBase FP.anyWord8 (ERanOut 1) -instance Get Int8 where get = cutEBase FP.anyInt8 (ERanOut 1) - --- | A type that can be parsed from binary given some environment. --- --- Making this levity polymorphic makes things pretty strange, but is useful. --- See @Binrep.Example.FileTable@. -class GetWith (r :: TYPE rep) a | a -> r where - -- | Parse from binary with the given environment. - getWith :: r -> Getter a - -- can no longer provide default implementation due to levity polymorphism - --default getWith :: Get a => r -> Getter a - --getWith _ = get - ---deriving anyclass instance Get a => GetWith r [a] - --- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You --- can't bind (LHS) a levity polymorphic value. -runGetWith - :: GetWith (r :: TYPE LiftedRep) a - => r -> B.ByteString -> Either E (a, B.ByteString) -runGetWith r bs = runGetter (getWith r) bs diff --git a/src/Binrep/Get/Flatparse.hs b/src/Binrep/Get/Flatparse.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Get/Flatparse.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 +{-# LANGUAGE BlockArguments #-} + +module Binrep.Get.Flatparse + ( Getter, Get(..), runGet, runGetter + , E(..), EBase(..), EGeneric(..), EGenericSum(..) + , eBase + , getEBase + -- , GetWith(..), runGetWith + , getGenericNonSum, getGenericSum + ) where + +import FlatParse.Basic qualified as FP +import Data.ByteString qualified as B + +import Binrep.Util.Class +import GHC.TypeLits ( TypeError ) + +import Data.Void +import Data.Word +import Data.Int +import Bytezap +import Bytezap.Bytes qualified as BZ + +import Data.Text ( Text ) + +import Numeric.Natural + +import GHC.Generics +import Generic.Data.Function.Traverse +import Generic.Data.Function.Common +import Generic.Data.Rep.Assert + +import GHC.Exts ( minusAddr#, Int(I#) ) + +type Getter a = FP.Parser E a + +-- | Structured parse error. +data E + = E Int EMiddle + + -- | Unhandled parse error. + -- + -- You get this if you don't change a flatparse fail to an error. + -- + -- Should not be set except by library code. + | EFail + + deriving stock (Eq, Show, Generic) + +data EMiddle + + -- | Parse error with no further context. + = EBase EBase + + -- | Somehow, we got two parse errors. + -- + -- I have a feeling that seeing this indicates a problem in your code. + | EAnd E EBase + + -- | Parse error decorated with generic info. + -- + -- Should not be set except by library code. + | EGeneric String {- ^ data type name -} (EGeneric E) + + deriving stock (Eq, Show, Generic) + +data EBase + = EExpectedByte Word8 Word8 + -- ^ expected first, got second + + | EOverlong Int Int + -- ^ expected first, got second + + | EExpected B.ByteString B.ByteString + -- ^ expected first, got second + + | EFailNamed String + -- ^ known fail + + | EFailParse String B.ByteString Word8 + -- ^ parse fail (where you parse a larger object, then a smaller one in it) + + | ERanOut Int + -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0) + -- + -- Actually a 'Natural', but we use 'Int' because that's what flatparse uses + -- internally. + + deriving stock (Eq, Show, Generic) + +-- | A generic context layer for a parse error of type @e@. +-- +-- Recursive: parse errors occurring in fields are wrapped up here. (Those +-- errors may also have a generic context layer.) +-- +-- Making this explicitly recursive may seem strange, but it clarifies that this +-- data type is to be seen as a layer over a top-level type. +data EGeneric e + -- | Parse error relating to sum types (constructors). + = EGenericSum (EGenericSum e) + + -- | Parse error in a constructor field. + | EGenericField + String -- ^ constructor name + (Maybe String) -- ^ field record name (if present) + Natural -- ^ field index in constructor + e -- ^ field parse error + deriving stock (Eq, Show, Generic) + +data EGenericSum e + -- | Parse error parsing prefix tag. + = EGenericSumTag e + + -- | Unable to match a constructor to the parsed prefix tag. + | EGenericSumTagNoMatch + [String] -- ^ constructors tested + Text -- ^ prettified prefix tag + deriving stock (Eq, Show, Generic) + +eBase :: EBase -> Getter a +eBase eb = FP.ParserT \_fp eob s st -> + let os = I# (minusAddr# eob s) + in FP.Err# st (E os $ EBase eb) + +getEBase :: Getter a -> EBase -> Getter a +getEBase (FP.ParserT f) eb = + FP.ParserT \fp eob s st -> + let os = I# (minusAddr# eob s) + in case f fp eob s st of + FP.Fail# st' -> FP.Err# st' (E os $ EBase eb) + FP.Err# st' e -> FP.Err# st' (E os $ EAnd e eb) + x -> x + +-- | Parse. On parse error, coat it in a generic context layer. +getWrapGeneric :: Get a => String -> (E -> EGeneric E) -> Getter a +getWrapGeneric = getWrapGeneric' get + +getWrapGeneric' :: Getter a -> String -> (E -> EGeneric E) -> Getter a +getWrapGeneric' (FP.ParserT f) cd fe = + FP.ParserT \fp eob s st -> + let os = I# (minusAddr# eob s) + in case f fp eob s st of + FP.Fail# st' -> FP.Err# st' (E os $ EGeneric cd $ fe EFail) + FP.Err# st' e -> FP.Err# st' (E os $ EGeneric cd $ fe e) + x -> x + +class Get a where + -- | Parse from binary. + get :: Getter a + +runGet :: Get a => B.ByteString -> Either E (a, B.ByteString) +runGet = runGetter get + +runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString) +runGetter g bs = case FP.runParser g bs of + FP.OK a bs' -> Right (a, bs') + FP.Fail -> Left EFail + FP.Err e -> Left e + +instance GenericTraverse (FP.Parser E) where + type GenericTraverseC (FP.Parser E) a = Get a + genericTraverseAction cd cc mcs si = + getWrapGeneric cd $ EGenericField cc mcs si + +instance GenericTraverseSum (FP.Parser E) where + genericTraverseSumPfxTagAction cd = + getWrapGeneric cd $ EGenericSum . EGenericSumTag + -- TODO proper offset info + genericTraverseSumNoMatchingCstrAction cd cstrs ptText = + FP.err $ E 0 $ EGeneric cd $ EGenericSum $ EGenericSumTagNoMatch cstrs ptText + +getGenericNonSum + :: forall {cd} {f} {asserts} a + . (Generic a, Rep a ~ D1 cd f, GTraverseNonSum cd (FP.Parser E) f + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + => Getter a +getGenericNonSum = genericTraverseNonSum @asserts + +getGenericSum + :: forall {cd} {f} {asserts} pt a + . ( Generic a, Rep a ~ D1 cd f, GTraverseSum 'SumOnly cd (FP.Parser E) f + , Get pt + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + => PfxTagCfg pt -> Getter a +getGenericSum = genericTraverseSum @'SumOnly @asserts + +instance TypeError ENoEmpty => Get Void where get = undefined +instance TypeError ENoSum => Get (Either a b) where get = undefined + +-- | Parse a bytestring and... immediate reserialize it. +-- +-- Note that this _does_ perform work: we make a new bytestring so we don't rely +-- on the input bytestring. To use the input bytestring directly, see +-- "Binrep.Type.Thin". +instance Get Write where + {-# INLINE get #-} + get = fmap BZ.byteString $ fmap B.copy $ FP.takeRest + +-- | Unit type parses nothing. +instance Get () where + {-# INLINE get #-} + get = pure () + +-- | Parse tuples left-to-right. +instance (Get l, Get r) => Get (l, r) where + {-# INLINE get #-} + get = do + l <- get + r <- get + pure (l, r) + +-- | Parse elements until EOF. Sometimes used at the "top" of binary formats. +instance Get a => Get [a] where + get = go + where + go = do + FP.withOption FP.eof (\() -> pure []) $ do + a <- get + as <- go + pure $ a : as + +-- | Return the rest of the input. +-- +-- A plain unannotated bytestring isn't very useful -- you'll usually want to +-- null-terminate or length-prefix it. +-- +-- Note that this _does_ perform work: we make a new bytestring so we don't rely +-- on the input bytestring. To use the input bytestring directly, see +-- "Binrep.Type.Thin". +instance Get B.ByteString where + {-# INLINE get #-} + get = B.copy <$> FP.takeRest + +-- | Unsigned byte. +instance Get Word8 where get = getEBase FP.anyWord8 (ERanOut 1) + +-- | Signed byte. +instance Get Int8 where get = getEBase FP.anyInt8 (ERanOut 1) + +{- +Multi-byte machine integers require an endianness to use. A common wrapper is +defined in "Binrep.Type.Int". +-} + +{- + +-- | A type that can be parsed from binary given some environment. +-- +-- Making this levity polymorphic makes things pretty strange, but is useful. +-- See @Binrep.Example.FileTable@. +class GetWith (r :: TYPE rep) a | a -> r where + -- | Parse from binary with the given environment. + getWith :: r -> Getter a + -- can no longer provide default implementation due to levity polymorphism + --default getWith :: Get a => r -> Getter a + --getWith _ = get + +--deriving anyclass instance Get a => GetWith r [a] + +-- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You +-- can't bind (LHS) a levity polymorphic value. +runGetWith + :: GetWith (r :: TYPE LiftedRep) a + => r -> B.ByteString -> Either E (a, B.ByteString) +runGetWith r bs = runGetter (getWith r) bs + +-} diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs deleted file mode 100644 --- a/src/Binrep/Put.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Binrep.Put where - -import Mason.Builder qualified as Mason - -import Data.ByteString qualified as B - -import Data.Word -import Data.Int -import Data.Void ( Void, absurd ) - -type Builder = Mason.BuilderFor Mason.StrictByteStringBackend - -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 - --- | Impossible to serialize 'Void'. -instance Put Void where - put = absurd - --- | Serialize each element in order. No length indicator, so parse until either --- error or EOF. Usually not what you want, but sometimes used at the "top" of --- binary formats. -instance Put a => Put [a] where - put = mconcat . map put - -instance (Put a, Put b) => Put (a, b) where - put (a, b) = put a <> put b - --- | Serialize the bytestring as-is. --- --- Careful -- the only way you're going to be able to parse this is to read --- until EOF. -instance Put B.ByteString where - put = Mason.byteString - {-# INLINE put #-} - --- need to give args for RankNTypes reasons I don't understand -instance Put Word8 where - put w = Mason.word8 w - {-# INLINE put #-} -instance Put Int8 where - put w = Mason.int8 w - {-# INLINE put #-} - --- | Put with inlined checks via an environment. -class PutWith r a where - -- | Attempt to serialize to binary with the given environment. - putWith :: r -> a -> Either String Builder - default putWith :: Put a => r -> a -> Either String Builder - putWith _ = putWithout - --- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding). -putWithout :: Put a => a -> Either String Builder -putWithout = Right . put - -instance Put a => PutWith r [a] - --- | Run the serializer with the given environment. -runPutWith :: PutWith r a => r -> a -> Either String B.ByteString -runPutWith r a = case putWith r a of Left e -> Left e - Right x -> Right $ runBuilder x diff --git a/src/Binrep/Put/Bytezap.hs b/src/Binrep/Put/Bytezap.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put/Bytezap.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance + +{- | Serialization using the bytezap library. + +bytezap serializers ("pokes") work by writing bytes into a pointer, which is +assumed to have _precisely_ the space required. The user must determine the +post-serialize length before the fact. For that reason, this module requires +that types to be serialized have a 'BLen' instance. In general, we are happy +about this, because a binrep type should always have an efficient and preferably +simple 'BLen' instance (and if not, it shouldn't be a binrep type). +-} + +module Binrep.Put.Bytezap where + +import Bytezap +import Bytezap.Poke.Bytes +import Bytezap.Poke.Int +import Data.ByteString qualified as B +import Binrep.BLen.Simple + +import Binrep.Util.Class +import GHC.TypeLits ( TypeError ) + +import Data.Void +import Data.Word +import Data.Int + +import GHC.Generics +import Generic.Data.Function.FoldMap +import Generic.Data.Function.Common +import Generic.Data.Rep.Assert + +class Put a where put :: a -> Poke + +runPut :: (BLen a, Put a) => a -> B.ByteString +runPut a = runPoke (blen a) (put a) +{-# INLINE runPut #-} + +instance GenericFoldMap Poke where + type GenericFoldMapC Poke a = Put a + genericFoldMapF = put + +-- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. +putGenericNonSum + :: forall {cd} {f} {asserts} a + . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Poke f + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + => a -> Poke +putGenericNonSum = genericFoldMapNonSum @asserts + +-- | Serialize a term of the sum type @a@ via its 'Generic' instance. +-- +-- You must provide a serializer for @a@'s constructors. This is regrettably +-- inefficient due to having to use 'String's. Alas. Do write your own instance +-- if you want better performance! +putGenericSum + :: forall {cd} {f} {asserts} a + . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Poke f + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + => (String -> Poke) -> a -> Poke +putGenericSum = genericFoldMapSum @'SumOnly @asserts + +instance TypeError ENoEmpty => Put Void where put = undefined +instance TypeError ENoSum => Put (Either a b) where put = undefined + +instance Put Write where + {-# INLINE put #-} + put = writePoke + +-- | Fairly useless because 'Poke' doesn't have a 'BLen' instance. +instance Put Poke where + {-# INLINE put #-} + put = id + +-- | Unit type serializes to nothing. How zen. +instance Put () where + {-# INLINE put #-} + put = mempty + +instance (Put l, Put r) => Put (l, r) where + {-# INLINE put #-} + put (l, r) = put l <> put r + +instance Put a => Put [a] where + {-# INLINE put #-} + put = mconcat . map put + +instance Put B.ByteString where + {-# INLINE put #-} + put = byteString + +instance Put Word8 where + {-# INLINE put #-} + put = w8 + +instance Put Int8 where + {-# INLINE put #-} + put = i8 diff --git a/src/Binrep/Put/Mason.hs b/src/Binrep/Put/Mason.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put/Mason.hs @@ -0,0 +1,102 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance + +-- TODO some instances are wrong, Void should be typeerror + +module Binrep.Put.Mason where + +import Mason.Builder qualified as Mason + +import Data.ByteString qualified as B + +import Data.Word +import Data.Int +import Data.Void ( Void, absurd ) + +import GHC.Generics +import Generic.Data.Function.FoldMap +import Generic.Data.Function.Common +import Generic.Data.Rep.Assert + +type Builder = Mason.BuilderFor Mason.StrictByteStringBackend + +class Put a where + -- | Serialize to binary. + put :: a -> Builder + +-- | Run the serializer. +runPut :: Put a => a -> B.ByteString +runPut = runBuilder . put + +runBuilder :: Builder -> B.ByteString +runBuilder = Mason.toStrictByteString + +instance GenericFoldMap Builder where + type GenericFoldMapC Builder a = Put a + genericFoldMapF = put + +-- | Serialize a term of the non-sum type @a@ via its 'Generic' instance. +putGenericNonSum + :: forall {cd} {f} {asserts} a + . ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Builder f + , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) + => a -> Builder +putGenericNonSum = genericFoldMapNonSum @asserts + +-- | Serialize a term of the sum type @a@ via its 'Generic' instance. +-- +-- You must provide a serializer for @a@'s constructors. This is regrettably +-- inefficient due to having to use 'String's. Alas. Do write your own instance +-- if you want better performance! +putGenericSum + :: forall {cd} {f} {asserts} a + . (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Builder f + , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) + => (String -> Builder) -> a -> Builder +putGenericSum = genericFoldMapSum @'SumOnly @asserts + +-- | Impossible to serialize 'Void'. +instance Put Void where + put = absurd + +-- | Serialize each element in order. No length indicator, so parse until either +-- error or EOF. Usually not what you want, but sometimes used at the "top" of +-- binary formats. +instance Put a => Put [a] where + put = mconcat . map put + +instance (Put a, Put b) => Put (a, b) where + put (a, b) = put a <> put b + +-- | Serialize the bytestring as-is. +-- +-- Careful -- the only way you're going to be able to parse this is to read +-- until EOF. +instance Put B.ByteString where + put = Mason.byteString + {-# INLINE put #-} + +-- need to give args for RankNTypes reasons I don't understand +instance Put Word8 where + put w = Mason.word8 w + {-# INLINE put #-} +instance Put Int8 where + put w = Mason.int8 w + {-# INLINE put #-} + +-- | Put with inlined checks via an environment. +class PutWith r a where + -- | Attempt to serialize to binary with the given environment. + putWith :: r -> a -> Either String Builder + default putWith :: Put a => r -> a -> Either String Builder + putWith _ = putWithout + +-- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding). +putWithout :: Put a => a -> Either String Builder +putWithout = Right . put + +instance Put a => PutWith r [a] + +-- | Run the serializer with the given environment. +runPutWith :: PutWith r a => r -> a -> Either String B.ByteString +runPutWith r a = case putWith r a of Left e -> Left e + Right x -> Right $ runBuilder x diff --git a/src/Binrep/Type/AsciiNat.hs b/src/Binrep/Type/AsciiNat.hs deleted file mode 100644 --- a/src/Binrep/Type/AsciiNat.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-| 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 ) - --- | 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 w -> eBase $ EFailParse "hex ASCII natural" bs w - 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 --- a/src/Binrep/Type/Byte.hs +++ b/src/Binrep/Type/Byte.hs @@ -17,809 +17,793 @@ 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 Bytezap qualified as BZ +import Bytezap.Poke.Int qualified as BZ import GHC.TypeNats -import GHC.Exts +import GHC.Word --- 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# +-- | Efficiently reify a list of type-level 'Natural' bytes to to a bytestring +-- builder. +-- +-- Attempting to reify a 'Natural' larger than 255 results in a type error. +-- +-- This is about as far as one should go for pointless performance here, I +-- should think. +class ReifyBytes (ns :: [Natural]) where reifyBytes :: BZ.Poke +instance ReifyBytes '[] where + {-# INLINE reifyBytes #-} + reifyBytes = mempty +instance (ByteVal n, ReifyBytes ns) => ReifyBytes (n ': ns) where + {-# INLINE reifyBytes #-} + reifyBytes = BZ.w8 (byteVal @n) <> reifyBytes @ns +class ByteVal (n :: Natural) where byteVal :: Word8 + instance ByteVal 0x00 where - byteVal _ = wordToWord8# 0x00## {-# INLINE byteVal #-} + byteVal = 0x00 instance ByteVal 0x01 where - byteVal _ = wordToWord8# 0x01## {-# INLINE byteVal #-} + byteVal = 0x01 instance ByteVal 0x02 where - byteVal _ = wordToWord8# 0x02## {-# INLINE byteVal #-} + byteVal = 0x02 instance ByteVal 0x03 where - byteVal _ = wordToWord8# 0x03## {-# INLINE byteVal #-} + byteVal = 0x03 instance ByteVal 0x04 where - byteVal _ = wordToWord8# 0x04## {-# INLINE byteVal #-} + byteVal = 0x04 instance ByteVal 0x05 where - byteVal _ = wordToWord8# 0x05## {-# INLINE byteVal #-} + byteVal = 0x05 instance ByteVal 0x06 where - byteVal _ = wordToWord8# 0x06## {-# INLINE byteVal #-} + byteVal = 0x06 instance ByteVal 0x07 where - byteVal _ = wordToWord8# 0x07## {-# INLINE byteVal #-} + byteVal = 0x07 instance ByteVal 0x08 where - byteVal _ = wordToWord8# 0x08## {-# INLINE byteVal #-} + byteVal = 0x08 instance ByteVal 0x09 where - byteVal _ = wordToWord8# 0x09## {-# INLINE byteVal #-} + byteVal = 0x09 instance ByteVal 0x0a where - byteVal _ = wordToWord8# 0x0a## {-# INLINE byteVal #-} + byteVal = 0x0a instance ByteVal 0x0b where - byteVal _ = wordToWord8# 0x0b## {-# INLINE byteVal #-} + byteVal = 0x0b instance ByteVal 0x0c where - byteVal _ = wordToWord8# 0x0c## {-# INLINE byteVal #-} + byteVal = 0x0c instance ByteVal 0x0d where - byteVal _ = wordToWord8# 0x0d## {-# INLINE byteVal #-} + byteVal = 0x0d instance ByteVal 0x0e where - byteVal _ = wordToWord8# 0x0e## {-# INLINE byteVal #-} + byteVal = 0x0e instance ByteVal 0x0f where - byteVal _ = wordToWord8# 0x0f## {-# INLINE byteVal #-} + byteVal = 0x0f instance ByteVal 0x10 where - byteVal _ = wordToWord8# 0x10## {-# INLINE byteVal #-} + byteVal = 0x10 instance ByteVal 0x11 where - byteVal _ = wordToWord8# 0x11## {-# INLINE byteVal #-} + byteVal = 0x11 instance ByteVal 0x12 where - byteVal _ = wordToWord8# 0x12## {-# INLINE byteVal #-} + byteVal = 0x12 instance ByteVal 0x13 where - byteVal _ = wordToWord8# 0x13## {-# INLINE byteVal #-} + byteVal = 0x13 instance ByteVal 0x14 where - byteVal _ = wordToWord8# 0x14## {-# INLINE byteVal #-} + byteVal = 0x14 instance ByteVal 0x15 where - byteVal _ = wordToWord8# 0x15## {-# INLINE byteVal #-} + byteVal = 0x15 instance ByteVal 0x16 where - byteVal _ = wordToWord8# 0x16## {-# INLINE byteVal #-} + byteVal = 0x16 instance ByteVal 0x17 where - byteVal _ = wordToWord8# 0x17## {-# INLINE byteVal #-} + byteVal = 0x17 instance ByteVal 0x18 where - byteVal _ = wordToWord8# 0x18## {-# INLINE byteVal #-} + byteVal = 0x18 instance ByteVal 0x19 where - byteVal _ = wordToWord8# 0x19## {-# INLINE byteVal #-} + byteVal = 0x19 instance ByteVal 0x1a where - byteVal _ = wordToWord8# 0x1a## {-# INLINE byteVal #-} + byteVal = 0x1a instance ByteVal 0x1b where - byteVal _ = wordToWord8# 0x1b## {-# INLINE byteVal #-} + byteVal = 0x1b instance ByteVal 0x1c where - byteVal _ = wordToWord8# 0x1c## {-# INLINE byteVal #-} + byteVal = 0x1c instance ByteVal 0x1d where - byteVal _ = wordToWord8# 0x1d## {-# INLINE byteVal #-} + byteVal = 0x1d instance ByteVal 0x1e where - byteVal _ = wordToWord8# 0x1e## {-# INLINE byteVal #-} + byteVal = 0x1e instance ByteVal 0x1f where - byteVal _ = wordToWord8# 0x1f## {-# INLINE byteVal #-} + byteVal = 0x1f instance ByteVal 0x20 where - byteVal _ = wordToWord8# 0x20## {-# INLINE byteVal #-} + byteVal = 0x20 instance ByteVal 0x21 where - byteVal _ = wordToWord8# 0x21## {-# INLINE byteVal #-} + byteVal = 0x21 instance ByteVal 0x22 where - byteVal _ = wordToWord8# 0x22## {-# INLINE byteVal #-} + byteVal = 0x22 instance ByteVal 0x23 where - byteVal _ = wordToWord8# 0x23## {-# INLINE byteVal #-} + byteVal = 0x23 instance ByteVal 0x24 where - byteVal _ = wordToWord8# 0x24## {-# INLINE byteVal #-} + byteVal = 0x24 instance ByteVal 0x25 where - byteVal _ = wordToWord8# 0x25## {-# INLINE byteVal #-} + byteVal = 0x25 instance ByteVal 0x26 where - byteVal _ = wordToWord8# 0x26## {-# INLINE byteVal #-} + byteVal = 0x26 instance ByteVal 0x27 where - byteVal _ = wordToWord8# 0x27## {-# INLINE byteVal #-} + byteVal = 0x27 instance ByteVal 0x28 where - byteVal _ = wordToWord8# 0x28## {-# INLINE byteVal #-} + byteVal = 0x28 instance ByteVal 0x29 where - byteVal _ = wordToWord8# 0x29## {-# INLINE byteVal #-} + byteVal = 0x29 instance ByteVal 0x2a where - byteVal _ = wordToWord8# 0x2a## {-# INLINE byteVal #-} + byteVal = 0x2a instance ByteVal 0x2b where - byteVal _ = wordToWord8# 0x2b## {-# INLINE byteVal #-} + byteVal = 0x2b instance ByteVal 0x2c where - byteVal _ = wordToWord8# 0x2c## {-# INLINE byteVal #-} + byteVal = 0x2c instance ByteVal 0x2d where - byteVal _ = wordToWord8# 0x2d## {-# INLINE byteVal #-} + byteVal = 0x2d instance ByteVal 0x2e where - byteVal _ = wordToWord8# 0x2e## {-# INLINE byteVal #-} + byteVal = 0x2e instance ByteVal 0x2f where - byteVal _ = wordToWord8# 0x2f## {-# INLINE byteVal #-} + byteVal = 0x2f instance ByteVal 0x30 where - byteVal _ = wordToWord8# 0x30## {-# INLINE byteVal #-} + byteVal = 0x30 instance ByteVal 0x31 where - byteVal _ = wordToWord8# 0x31## {-# INLINE byteVal #-} + byteVal = 0x31 instance ByteVal 0x32 where - byteVal _ = wordToWord8# 0x32## {-# INLINE byteVal #-} + byteVal = 0x32 instance ByteVal 0x33 where - byteVal _ = wordToWord8# 0x33## {-# INLINE byteVal #-} + byteVal = 0x33 instance ByteVal 0x34 where - byteVal _ = wordToWord8# 0x34## {-# INLINE byteVal #-} + byteVal = 0x34 instance ByteVal 0x35 where - byteVal _ = wordToWord8# 0x35## {-# INLINE byteVal #-} + byteVal = 0x35 instance ByteVal 0x36 where - byteVal _ = wordToWord8# 0x36## {-# INLINE byteVal #-} + byteVal = 0x36 instance ByteVal 0x37 where - byteVal _ = wordToWord8# 0x37## {-# INLINE byteVal #-} + byteVal = 0x37 instance ByteVal 0x38 where - byteVal _ = wordToWord8# 0x38## {-# INLINE byteVal #-} + byteVal = 0x38 instance ByteVal 0x39 where - byteVal _ = wordToWord8# 0x39## {-# INLINE byteVal #-} + byteVal = 0x39 instance ByteVal 0x3a where - byteVal _ = wordToWord8# 0x3a## {-# INLINE byteVal #-} + byteVal = 0x3a instance ByteVal 0x3b where - byteVal _ = wordToWord8# 0x3b## {-# INLINE byteVal #-} + byteVal = 0x3b instance ByteVal 0x3c where - byteVal _ = wordToWord8# 0x3c## {-# INLINE byteVal #-} + byteVal = 0x3c instance ByteVal 0x3d where - byteVal _ = wordToWord8# 0x3d## {-# INLINE byteVal #-} + byteVal = 0x3d instance ByteVal 0x3e where - byteVal _ = wordToWord8# 0x3e## {-# INLINE byteVal #-} + byteVal = 0x3e instance ByteVal 0x3f where - byteVal _ = wordToWord8# 0x3f## {-# INLINE byteVal #-} + byteVal = 0x3f instance ByteVal 0x40 where - byteVal _ = wordToWord8# 0x40## {-# INLINE byteVal #-} + byteVal = 0x40 instance ByteVal 0x41 where - byteVal _ = wordToWord8# 0x41## {-# INLINE byteVal #-} + byteVal = 0x41 instance ByteVal 0x42 where - byteVal _ = wordToWord8# 0x42## {-# INLINE byteVal #-} + byteVal = 0x42 instance ByteVal 0x43 where - byteVal _ = wordToWord8# 0x43## {-# INLINE byteVal #-} + byteVal = 0x43 instance ByteVal 0x44 where - byteVal _ = wordToWord8# 0x44## {-# INLINE byteVal #-} + byteVal = 0x44 instance ByteVal 0x45 where - byteVal _ = wordToWord8# 0x45## {-# INLINE byteVal #-} + byteVal = 0x45 instance ByteVal 0x46 where - byteVal _ = wordToWord8# 0x46## {-# INLINE byteVal #-} + byteVal = 0x46 instance ByteVal 0x47 where - byteVal _ = wordToWord8# 0x47## {-# INLINE byteVal #-} + byteVal = 0x47 instance ByteVal 0x48 where - byteVal _ = wordToWord8# 0x48## {-# INLINE byteVal #-} + byteVal = 0x48 instance ByteVal 0x49 where - byteVal _ = wordToWord8# 0x49## {-# INLINE byteVal #-} + byteVal = 0x49 instance ByteVal 0x4a where - byteVal _ = wordToWord8# 0x4a## {-# INLINE byteVal #-} + byteVal = 0x4a instance ByteVal 0x4b where - byteVal _ = wordToWord8# 0x4b## {-# INLINE byteVal #-} + byteVal = 0x4b instance ByteVal 0x4c where - byteVal _ = wordToWord8# 0x4c## {-# INLINE byteVal #-} + byteVal = 0x4c instance ByteVal 0x4d where - byteVal _ = wordToWord8# 0x4d## {-# INLINE byteVal #-} + byteVal = 0x4d instance ByteVal 0x4e where - byteVal _ = wordToWord8# 0x4e## {-# INLINE byteVal #-} + byteVal = 0x4e instance ByteVal 0x4f where - byteVal _ = wordToWord8# 0x4f## {-# INLINE byteVal #-} + byteVal = 0x4f instance ByteVal 0x50 where - byteVal _ = wordToWord8# 0x50## {-# INLINE byteVal #-} + byteVal = 0x50 instance ByteVal 0x51 where - byteVal _ = wordToWord8# 0x51## {-# INLINE byteVal #-} + byteVal = 0x51 instance ByteVal 0x52 where - byteVal _ = wordToWord8# 0x52## {-# INLINE byteVal #-} + byteVal = 0x52 instance ByteVal 0x53 where - byteVal _ = wordToWord8# 0x53## {-# INLINE byteVal #-} + byteVal = 0x53 instance ByteVal 0x54 where - byteVal _ = wordToWord8# 0x54## {-# INLINE byteVal #-} + byteVal = 0x54 instance ByteVal 0x55 where - byteVal _ = wordToWord8# 0x55## {-# INLINE byteVal #-} + byteVal = 0x55 instance ByteVal 0x56 where - byteVal _ = wordToWord8# 0x56## {-# INLINE byteVal #-} + byteVal = 0x56 instance ByteVal 0x57 where - byteVal _ = wordToWord8# 0x57## {-# INLINE byteVal #-} + byteVal = 0x57 instance ByteVal 0x58 where - byteVal _ = wordToWord8# 0x58## {-# INLINE byteVal #-} + byteVal = 0x58 instance ByteVal 0x59 where - byteVal _ = wordToWord8# 0x59## {-# INLINE byteVal #-} + byteVal = 0x59 instance ByteVal 0x5a where - byteVal _ = wordToWord8# 0x5a## {-# INLINE byteVal #-} + byteVal = 0x5a instance ByteVal 0x5b where - byteVal _ = wordToWord8# 0x5b## {-# INLINE byteVal #-} + byteVal = 0x5b instance ByteVal 0x5c where - byteVal _ = wordToWord8# 0x5c## {-# INLINE byteVal #-} + byteVal = 0x5c instance ByteVal 0x5d where - byteVal _ = wordToWord8# 0x5d## {-# INLINE byteVal #-} + byteVal = 0x5d instance ByteVal 0x5e where - byteVal _ = wordToWord8# 0x5e## {-# INLINE byteVal #-} + byteVal = 0x5e instance ByteVal 0x5f where - byteVal _ = wordToWord8# 0x5f## {-# INLINE byteVal #-} + byteVal = 0x5f instance ByteVal 0x60 where - byteVal _ = wordToWord8# 0x60## {-# INLINE byteVal #-} + byteVal = 0x60 instance ByteVal 0x61 where - byteVal _ = wordToWord8# 0x61## {-# INLINE byteVal #-} + byteVal = 0x61 instance ByteVal 0x62 where - byteVal _ = wordToWord8# 0x62## {-# INLINE byteVal #-} + byteVal = 0x62 instance ByteVal 0x63 where - byteVal _ = wordToWord8# 0x63## {-# INLINE byteVal #-} + byteVal = 0x63 instance ByteVal 0x64 where - byteVal _ = wordToWord8# 0x64## {-# INLINE byteVal #-} + byteVal = 0x64 instance ByteVal 0x65 where - byteVal _ = wordToWord8# 0x65## {-# INLINE byteVal #-} + byteVal = 0x65 instance ByteVal 0x66 where - byteVal _ = wordToWord8# 0x66## {-# INLINE byteVal #-} + byteVal = 0x66 instance ByteVal 0x67 where - byteVal _ = wordToWord8# 0x67## {-# INLINE byteVal #-} + byteVal = 0x67 instance ByteVal 0x68 where - byteVal _ = wordToWord8# 0x68## {-# INLINE byteVal #-} + byteVal = 0x68 instance ByteVal 0x69 where - byteVal _ = wordToWord8# 0x69## {-# INLINE byteVal #-} + byteVal = 0x69 instance ByteVal 0x6a where - byteVal _ = wordToWord8# 0x6a## {-# INLINE byteVal #-} + byteVal = 0x6a instance ByteVal 0x6b where - byteVal _ = wordToWord8# 0x6b## {-# INLINE byteVal #-} + byteVal = 0x6b instance ByteVal 0x6c where - byteVal _ = wordToWord8# 0x6c## {-# INLINE byteVal #-} + byteVal = 0x6c instance ByteVal 0x6d where - byteVal _ = wordToWord8# 0x6d## {-# INLINE byteVal #-} + byteVal = 0x6d instance ByteVal 0x6e where - byteVal _ = wordToWord8# 0x6e## {-# INLINE byteVal #-} + byteVal = 0x6e instance ByteVal 0x6f where - byteVal _ = wordToWord8# 0x6f## {-# INLINE byteVal #-} + byteVal = 0x6f instance ByteVal 0x70 where - byteVal _ = wordToWord8# 0x70## {-# INLINE byteVal #-} + byteVal = 0x70 instance ByteVal 0x71 where - byteVal _ = wordToWord8# 0x71## {-# INLINE byteVal #-} + byteVal = 0x71 instance ByteVal 0x72 where - byteVal _ = wordToWord8# 0x72## {-# INLINE byteVal #-} + byteVal = 0x72 instance ByteVal 0x73 where - byteVal _ = wordToWord8# 0x73## {-# INLINE byteVal #-} + byteVal = 0x73 instance ByteVal 0x74 where - byteVal _ = wordToWord8# 0x74## {-# INLINE byteVal #-} + byteVal = 0x74 instance ByteVal 0x75 where - byteVal _ = wordToWord8# 0x75## {-# INLINE byteVal #-} + byteVal = 0x75 instance ByteVal 0x76 where - byteVal _ = wordToWord8# 0x76## {-# INLINE byteVal #-} + byteVal = 0x76 instance ByteVal 0x77 where - byteVal _ = wordToWord8# 0x77## {-# INLINE byteVal #-} + byteVal = 0x77 instance ByteVal 0x78 where - byteVal _ = wordToWord8# 0x78## {-# INLINE byteVal #-} + byteVal = 0x78 instance ByteVal 0x79 where - byteVal _ = wordToWord8# 0x79## {-# INLINE byteVal #-} + byteVal = 0x79 instance ByteVal 0x7a where - byteVal _ = wordToWord8# 0x7a## {-# INLINE byteVal #-} + byteVal = 0x7a instance ByteVal 0x7b where - byteVal _ = wordToWord8# 0x7b## {-# INLINE byteVal #-} + byteVal = 0x7b instance ByteVal 0x7c where - byteVal _ = wordToWord8# 0x7c## {-# INLINE byteVal #-} + byteVal = 0x7c instance ByteVal 0x7d where - byteVal _ = wordToWord8# 0x7d## {-# INLINE byteVal #-} + byteVal = 0x7d instance ByteVal 0x7e where - byteVal _ = wordToWord8# 0x7e## {-# INLINE byteVal #-} + byteVal = 0x7e instance ByteVal 0x7f where - byteVal _ = wordToWord8# 0x7f## {-# INLINE byteVal #-} + byteVal = 0x7f instance ByteVal 0x80 where - byteVal _ = wordToWord8# 0x80## {-# INLINE byteVal #-} + byteVal = 0x80 instance ByteVal 0x81 where - byteVal _ = wordToWord8# 0x81## {-# INLINE byteVal #-} + byteVal = 0x81 instance ByteVal 0x82 where - byteVal _ = wordToWord8# 0x82## {-# INLINE byteVal #-} + byteVal = 0x82 instance ByteVal 0x83 where - byteVal _ = wordToWord8# 0x83## {-# INLINE byteVal #-} + byteVal = 0x83 instance ByteVal 0x84 where - byteVal _ = wordToWord8# 0x84## {-# INLINE byteVal #-} + byteVal = 0x84 instance ByteVal 0x85 where - byteVal _ = wordToWord8# 0x85## {-# INLINE byteVal #-} + byteVal = 0x85 instance ByteVal 0x86 where - byteVal _ = wordToWord8# 0x86## {-# INLINE byteVal #-} + byteVal = 0x86 instance ByteVal 0x87 where - byteVal _ = wordToWord8# 0x87## {-# INLINE byteVal #-} + byteVal = 0x87 instance ByteVal 0x88 where - byteVal _ = wordToWord8# 0x88## {-# INLINE byteVal #-} + byteVal = 0x88 instance ByteVal 0x89 where - byteVal _ = wordToWord8# 0x89## {-# INLINE byteVal #-} + byteVal = 0x89 instance ByteVal 0x8a where - byteVal _ = wordToWord8# 0x8a## {-# INLINE byteVal #-} + byteVal = 0x8a instance ByteVal 0x8b where - byteVal _ = wordToWord8# 0x8b## {-# INLINE byteVal #-} + byteVal = 0x8b instance ByteVal 0x8c where - byteVal _ = wordToWord8# 0x8c## {-# INLINE byteVal #-} + byteVal = 0x8c instance ByteVal 0x8d where - byteVal _ = wordToWord8# 0x8d## {-# INLINE byteVal #-} + byteVal = 0x8d instance ByteVal 0x8e where - byteVal _ = wordToWord8# 0x8e## {-# INLINE byteVal #-} + byteVal = 0x8e instance ByteVal 0x8f where - byteVal _ = wordToWord8# 0x8f## {-# INLINE byteVal #-} + byteVal = 0x8f instance ByteVal 0x90 where - byteVal _ = wordToWord8# 0x90## {-# INLINE byteVal #-} + byteVal = 0x90 instance ByteVal 0x91 where - byteVal _ = wordToWord8# 0x91## {-# INLINE byteVal #-} + byteVal = 0x91 instance ByteVal 0x92 where - byteVal _ = wordToWord8# 0x92## {-# INLINE byteVal #-} + byteVal = 0x92 instance ByteVal 0x93 where - byteVal _ = wordToWord8# 0x93## {-# INLINE byteVal #-} + byteVal = 0x93 instance ByteVal 0x94 where - byteVal _ = wordToWord8# 0x94## {-# INLINE byteVal #-} + byteVal = 0x94 instance ByteVal 0x95 where - byteVal _ = wordToWord8# 0x95## {-# INLINE byteVal #-} + byteVal = 0x95 instance ByteVal 0x96 where - byteVal _ = wordToWord8# 0x96## {-# INLINE byteVal #-} + byteVal = 0x96 instance ByteVal 0x97 where - byteVal _ = wordToWord8# 0x97## {-# INLINE byteVal #-} + byteVal = 0x97 instance ByteVal 0x98 where - byteVal _ = wordToWord8# 0x98## {-# INLINE byteVal #-} + byteVal = 0x98 instance ByteVal 0x99 where - byteVal _ = wordToWord8# 0x99## {-# INLINE byteVal #-} + byteVal = 0x99 instance ByteVal 0x9a where - byteVal _ = wordToWord8# 0x9a## {-# INLINE byteVal #-} + byteVal = 0x9a instance ByteVal 0x9b where - byteVal _ = wordToWord8# 0x9b## {-# INLINE byteVal #-} + byteVal = 0x9b instance ByteVal 0x9c where - byteVal _ = wordToWord8# 0x9c## {-# INLINE byteVal #-} + byteVal = 0x9c instance ByteVal 0x9d where - byteVal _ = wordToWord8# 0x9d## {-# INLINE byteVal #-} + byteVal = 0x9d instance ByteVal 0x9e where - byteVal _ = wordToWord8# 0x9e## {-# INLINE byteVal #-} + byteVal = 0x9e instance ByteVal 0x9f where - byteVal _ = wordToWord8# 0x9f## {-# INLINE byteVal #-} + byteVal = 0x9f instance ByteVal 0xa0 where - byteVal _ = wordToWord8# 0xa0## {-# INLINE byteVal #-} + byteVal = 0xa0 instance ByteVal 0xa1 where - byteVal _ = wordToWord8# 0xa1## {-# INLINE byteVal #-} + byteVal = 0xa1 instance ByteVal 0xa2 where - byteVal _ = wordToWord8# 0xa2## {-# INLINE byteVal #-} + byteVal = 0xa2 instance ByteVal 0xa3 where - byteVal _ = wordToWord8# 0xa3## {-# INLINE byteVal #-} + byteVal = 0xa3 instance ByteVal 0xa4 where - byteVal _ = wordToWord8# 0xa4## {-# INLINE byteVal #-} + byteVal = 0xa4 instance ByteVal 0xa5 where - byteVal _ = wordToWord8# 0xa5## {-# INLINE byteVal #-} + byteVal = 0xa5 instance ByteVal 0xa6 where - byteVal _ = wordToWord8# 0xa6## {-# INLINE byteVal #-} + byteVal = 0xa6 instance ByteVal 0xa7 where - byteVal _ = wordToWord8# 0xa7## {-# INLINE byteVal #-} + byteVal = 0xa7 instance ByteVal 0xa8 where - byteVal _ = wordToWord8# 0xa8## {-# INLINE byteVal #-} + byteVal = 0xa8 instance ByteVal 0xa9 where - byteVal _ = wordToWord8# 0xa9## {-# INLINE byteVal #-} + byteVal = 0xa9 instance ByteVal 0xaa where - byteVal _ = wordToWord8# 0xaa## {-# INLINE byteVal #-} + byteVal = 0xaa instance ByteVal 0xab where - byteVal _ = wordToWord8# 0xab## {-# INLINE byteVal #-} + byteVal = 0xab instance ByteVal 0xac where - byteVal _ = wordToWord8# 0xac## {-# INLINE byteVal #-} + byteVal = 0xac instance ByteVal 0xad where - byteVal _ = wordToWord8# 0xad## {-# INLINE byteVal #-} + byteVal = 0xad instance ByteVal 0xae where - byteVal _ = wordToWord8# 0xae## {-# INLINE byteVal #-} + byteVal = 0xae instance ByteVal 0xaf where - byteVal _ = wordToWord8# 0xaf## {-# INLINE byteVal #-} + byteVal = 0xaf instance ByteVal 0xb0 where - byteVal _ = wordToWord8# 0xb0## {-# INLINE byteVal #-} + byteVal = 0xb0 instance ByteVal 0xb1 where - byteVal _ = wordToWord8# 0xb1## {-# INLINE byteVal #-} + byteVal = 0xb1 instance ByteVal 0xb2 where - byteVal _ = wordToWord8# 0xb2## {-# INLINE byteVal #-} + byteVal = 0xb2 instance ByteVal 0xb3 where - byteVal _ = wordToWord8# 0xb3## {-# INLINE byteVal #-} + byteVal = 0xb3 instance ByteVal 0xb4 where - byteVal _ = wordToWord8# 0xb4## {-# INLINE byteVal #-} + byteVal = 0xb4 instance ByteVal 0xb5 where - byteVal _ = wordToWord8# 0xb5## {-# INLINE byteVal #-} + byteVal = 0xb5 instance ByteVal 0xb6 where - byteVal _ = wordToWord8# 0xb6## {-# INLINE byteVal #-} + byteVal = 0xb6 instance ByteVal 0xb7 where - byteVal _ = wordToWord8# 0xb7## {-# INLINE byteVal #-} + byteVal = 0xb7 instance ByteVal 0xb8 where - byteVal _ = wordToWord8# 0xb8## {-# INLINE byteVal #-} + byteVal = 0xb8 instance ByteVal 0xb9 where - byteVal _ = wordToWord8# 0xb9## {-# INLINE byteVal #-} + byteVal = 0xb9 instance ByteVal 0xba where - byteVal _ = wordToWord8# 0xba## {-# INLINE byteVal #-} + byteVal = 0xba instance ByteVal 0xbb where - byteVal _ = wordToWord8# 0xbb## {-# INLINE byteVal #-} + byteVal = 0xbb instance ByteVal 0xbc where - byteVal _ = wordToWord8# 0xbc## {-# INLINE byteVal #-} + byteVal = 0xbc instance ByteVal 0xbd where - byteVal _ = wordToWord8# 0xbd## {-# INLINE byteVal #-} + byteVal = 0xbd instance ByteVal 0xbe where - byteVal _ = wordToWord8# 0xbe## {-# INLINE byteVal #-} + byteVal = 0xbe instance ByteVal 0xbf where - byteVal _ = wordToWord8# 0xbf## {-# INLINE byteVal #-} + byteVal = 0xbf instance ByteVal 0xc0 where - byteVal _ = wordToWord8# 0xc0## {-# INLINE byteVal #-} + byteVal = 0xc0 instance ByteVal 0xc1 where - byteVal _ = wordToWord8# 0xc1## {-# INLINE byteVal #-} + byteVal = 0xc1 instance ByteVal 0xc2 where - byteVal _ = wordToWord8# 0xc2## {-# INLINE byteVal #-} + byteVal = 0xc2 instance ByteVal 0xc3 where - byteVal _ = wordToWord8# 0xc3## {-# INLINE byteVal #-} + byteVal = 0xc3 instance ByteVal 0xc4 where - byteVal _ = wordToWord8# 0xc4## {-# INLINE byteVal #-} + byteVal = 0xc4 instance ByteVal 0xc5 where - byteVal _ = wordToWord8# 0xc5## {-# INLINE byteVal #-} + byteVal = 0xc5 instance ByteVal 0xc6 where - byteVal _ = wordToWord8# 0xc6## {-# INLINE byteVal #-} + byteVal = 0xc6 instance ByteVal 0xc7 where - byteVal _ = wordToWord8# 0xc7## {-# INLINE byteVal #-} + byteVal = 0xc7 instance ByteVal 0xc8 where - byteVal _ = wordToWord8# 0xc8## {-# INLINE byteVal #-} + byteVal = 0xc8 instance ByteVal 0xc9 where - byteVal _ = wordToWord8# 0xc9## {-# INLINE byteVal #-} + byteVal = 0xc9 instance ByteVal 0xca where - byteVal _ = wordToWord8# 0xca## {-# INLINE byteVal #-} + byteVal = 0xca instance ByteVal 0xcb where - byteVal _ = wordToWord8# 0xcb## {-# INLINE byteVal #-} + byteVal = 0xcb instance ByteVal 0xcc where - byteVal _ = wordToWord8# 0xcc## {-# INLINE byteVal #-} + byteVal = 0xcc instance ByteVal 0xcd where - byteVal _ = wordToWord8# 0xcd## {-# INLINE byteVal #-} + byteVal = 0xcd instance ByteVal 0xce where - byteVal _ = wordToWord8# 0xce## {-# INLINE byteVal #-} + byteVal = 0xce instance ByteVal 0xcf where - byteVal _ = wordToWord8# 0xcf## {-# INLINE byteVal #-} + byteVal = 0xcf instance ByteVal 0xd0 where - byteVal _ = wordToWord8# 0xd0## {-# INLINE byteVal #-} + byteVal = 0xd0 instance ByteVal 0xd1 where - byteVal _ = wordToWord8# 0xd1## {-# INLINE byteVal #-} + byteVal = 0xd1 instance ByteVal 0xd2 where - byteVal _ = wordToWord8# 0xd2## {-# INLINE byteVal #-} + byteVal = 0xd2 instance ByteVal 0xd3 where - byteVal _ = wordToWord8# 0xd3## {-# INLINE byteVal #-} + byteVal = 0xd3 instance ByteVal 0xd4 where - byteVal _ = wordToWord8# 0xd4## {-# INLINE byteVal #-} + byteVal = 0xd4 instance ByteVal 0xd5 where - byteVal _ = wordToWord8# 0xd5## {-# INLINE byteVal #-} + byteVal = 0xd5 instance ByteVal 0xd6 where - byteVal _ = wordToWord8# 0xd6## {-# INLINE byteVal #-} + byteVal = 0xd6 instance ByteVal 0xd7 where - byteVal _ = wordToWord8# 0xd7## {-# INLINE byteVal #-} + byteVal = 0xd7 instance ByteVal 0xd8 where - byteVal _ = wordToWord8# 0xd8## {-# INLINE byteVal #-} + byteVal = 0xd8 instance ByteVal 0xd9 where - byteVal _ = wordToWord8# 0xd9## {-# INLINE byteVal #-} + byteVal = 0xd9 instance ByteVal 0xda where - byteVal _ = wordToWord8# 0xda## {-# INLINE byteVal #-} + byteVal = 0xda instance ByteVal 0xdb where - byteVal _ = wordToWord8# 0xdb## {-# INLINE byteVal #-} + byteVal = 0xdb instance ByteVal 0xdc where - byteVal _ = wordToWord8# 0xdc## {-# INLINE byteVal #-} + byteVal = 0xdc instance ByteVal 0xdd where - byteVal _ = wordToWord8# 0xdd## {-# INLINE byteVal #-} + byteVal = 0xdd instance ByteVal 0xde where - byteVal _ = wordToWord8# 0xde## {-# INLINE byteVal #-} + byteVal = 0xde instance ByteVal 0xdf where - byteVal _ = wordToWord8# 0xdf## {-# INLINE byteVal #-} + byteVal = 0xdf instance ByteVal 0xe0 where - byteVal _ = wordToWord8# 0xe0## {-# INLINE byteVal #-} + byteVal = 0xe0 instance ByteVal 0xe1 where - byteVal _ = wordToWord8# 0xe1## {-# INLINE byteVal #-} + byteVal = 0xe1 instance ByteVal 0xe2 where - byteVal _ = wordToWord8# 0xe2## {-# INLINE byteVal #-} + byteVal = 0xe2 instance ByteVal 0xe3 where - byteVal _ = wordToWord8# 0xe3## {-# INLINE byteVal #-} + byteVal = 0xe3 instance ByteVal 0xe4 where - byteVal _ = wordToWord8# 0xe4## {-# INLINE byteVal #-} + byteVal = 0xe4 instance ByteVal 0xe5 where - byteVal _ = wordToWord8# 0xe5## {-# INLINE byteVal #-} + byteVal = 0xe5 instance ByteVal 0xe6 where - byteVal _ = wordToWord8# 0xe6## {-# INLINE byteVal #-} + byteVal = 0xe6 instance ByteVal 0xe7 where - byteVal _ = wordToWord8# 0xe7## {-# INLINE byteVal #-} + byteVal = 0xe7 instance ByteVal 0xe8 where - byteVal _ = wordToWord8# 0xe8## {-# INLINE byteVal #-} + byteVal = 0xe8 instance ByteVal 0xe9 where - byteVal _ = wordToWord8# 0xe9## {-# INLINE byteVal #-} + byteVal = 0xe9 instance ByteVal 0xea where - byteVal _ = wordToWord8# 0xea## {-# INLINE byteVal #-} + byteVal = 0xea instance ByteVal 0xeb where - byteVal _ = wordToWord8# 0xeb## {-# INLINE byteVal #-} + byteVal = 0xeb instance ByteVal 0xec where - byteVal _ = wordToWord8# 0xec## {-# INLINE byteVal #-} + byteVal = 0xec instance ByteVal 0xed where - byteVal _ = wordToWord8# 0xed## {-# INLINE byteVal #-} + byteVal = 0xed instance ByteVal 0xee where - byteVal _ = wordToWord8# 0xee## {-# INLINE byteVal #-} + byteVal = 0xee instance ByteVal 0xef where - byteVal _ = wordToWord8# 0xef## {-# INLINE byteVal #-} + byteVal = 0xef instance ByteVal 0xf0 where - byteVal _ = wordToWord8# 0xf0## {-# INLINE byteVal #-} + byteVal = 0xf0 instance ByteVal 0xf1 where - byteVal _ = wordToWord8# 0xf1## {-# INLINE byteVal #-} + byteVal = 0xf1 instance ByteVal 0xf2 where - byteVal _ = wordToWord8# 0xf2## {-# INLINE byteVal #-} + byteVal = 0xf2 instance ByteVal 0xf3 where - byteVal _ = wordToWord8# 0xf3## {-# INLINE byteVal #-} + byteVal = 0xf3 instance ByteVal 0xf4 where - byteVal _ = wordToWord8# 0xf4## {-# INLINE byteVal #-} + byteVal = 0xf4 instance ByteVal 0xf5 where - byteVal _ = wordToWord8# 0xf5## {-# INLINE byteVal #-} + byteVal = 0xf5 instance ByteVal 0xf6 where - byteVal _ = wordToWord8# 0xf6## {-# INLINE byteVal #-} + byteVal = 0xf6 instance ByteVal 0xf7 where - byteVal _ = wordToWord8# 0xf7## {-# INLINE byteVal #-} + byteVal = 0xf7 instance ByteVal 0xf8 where - byteVal _ = wordToWord8# 0xf8## {-# INLINE byteVal #-} + byteVal = 0xf8 instance ByteVal 0xf9 where - byteVal _ = wordToWord8# 0xf9## {-# INLINE byteVal #-} + byteVal = 0xf9 instance ByteVal 0xfa where - byteVal _ = wordToWord8# 0xfa## {-# INLINE byteVal #-} + byteVal = 0xfa instance ByteVal 0xfb where - byteVal _ = wordToWord8# 0xfb## {-# INLINE byteVal #-} + byteVal = 0xfb instance ByteVal 0xfc where - byteVal _ = wordToWord8# 0xfc## {-# INLINE byteVal #-} + byteVal = 0xfc instance ByteVal 0xfd where - byteVal _ = wordToWord8# 0xfd## {-# INLINE byteVal #-} + byteVal = 0xfd instance ByteVal 0xfe where - byteVal _ = wordToWord8# 0xfe## {-# INLINE byteVal #-} + byteVal = 0xfe 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 'Natural' bytes to to a bytestring --- builder. --- --- Attempting to reify a 'Natural' larger than 255 results in a type error. --- --- This is about as far as one should go for pointless performance here, I --- should think. -class ReifyBytes (ns :: [Natural]) where reifyBytes :: Builder -instance (n ~ Length ns, KnownNat n, WriteReifiedBytes ns) => ReifyBytes ns where - reifyBytes = Mason.primFixed (BI.fixedPrim (fromIntegral n) go) () - where - n = natVal'' @n - go = \() (Ptr p#) -> writeReifiedBytes @ns p# - --- bit ugly -class WriteReifiedBytes (ns :: [Natural]) where writeReifiedBytes :: Addr# -> IO () -instance WriteReifiedBytes '[] where writeReifiedBytes _ = pure () -instance (ByteVal n, WriteReifiedBytes ns) => WriteReifiedBytes (n ': ns) where - writeReifiedBytes p# = - case runRW# (writeWord8OffAddr# p# 0# w#) of - _ -> writeReifiedBytes @ns (plusAddr# p# 1#) - where w# = byteVal @n proxy# + byteVal = 0xff diff --git a/src/Binrep/Type/ByteString.hs b/src/Binrep/Type/ByteString.hs deleted file mode 100644 --- a/src/Binrep/Type/ByteString.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- | 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 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 :: Getter B.ByteString -getCString = FP.cut FP.anyCString $ EBase $ EFailNamed "cstring" - -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 --- a/src/Binrep/Type/Common.hs +++ b/src/Binrep/Type/Common.hs @@ -5,6 +5,6 @@ -- | Byte order. data Endianness - = BE -- ^ big endian, MSB first. e.g. most network protocols - | LE -- ^ little endian, MSB last. e.g. most processor architectures + = LE -- ^ little endian, MSB last. e.g. most processor architectures + | BE -- ^ big endian, MSB first. e.g. most network protocols deriving stock (Generic, Data, Show, Eq) diff --git a/src/Binrep/Type/Int.hs b/src/Binrep/Type/Int.hs --- a/src/Binrep/Type/Int.hs +++ b/src/Binrep/Type/Int.hs @@ -1,141 +1,142 @@ -{-# LANGUAGE UndecidableInstances #-} +-- | "Machine" integers: sized integers & naturals with explicit endianness type +-- tags for serialization. -{- 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 --} +{-# LANGUAGE CPP #-} -- for host endianness checking +{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic module Binrep.Type.Int where -import Binrep +import Binrep.Put.Mason qualified as Mason +import Binrep.Put.Bytezap qualified as Bytezap +import Binrep.Get.Flatparse qualified as Flatparse +import Binrep.BLen.Simple qualified as Simple +import Binrep.CBLen + +import Bytezap.Poke.Int qualified as BZ +import FlatParse.Basic qualified as FP + import Binrep.Type.Common ( Endianness(..) ) import Strongweak import Data.Word import Data.Int import Data.Aeson -import FlatParse.Basic qualified as FP -import Mason.Builder qualified as Mason import GHC.Generics ( Generic ) -import Data.Data ( Typeable, Data ) +import Data.Data ( Data ) import GHC.TypeNats --- | Wrapper type grouping machine integers (sign, size) along with an explicit --- endianness. +import Binrep.Via ( Binreply(..) ) + +-- | Machine integer sign. -- --- 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: +-- Signed integers use two's complement for representation. +data ISign + = U -- ^ unsigned + | I -- ^ signed (two's complement) + deriving stock (Generic, Data, Show, Eq) + +-- | A type tagged with the endianness (byte order) to use when serializing. -- --- >>> 255 + 1 :: I 'U 'I1 e --- 0 +-- Intended to be used to wrap existing types which do not otherwise expose +-- endianness, namely the machine integers 'Int32', 'Word64' etc. As such, it +-- derives various relevant type classes using the wrapped type. -- --- >>> 255 + 1 :: I 'U 'I2 e --- 256 -newtype I (sign :: ISign) (size :: ISize) (e :: Endianness) - = I { getI :: IRep sign size } - deriving stock (Generic) +-- May be considered a restricted 'Data.Tagged.Tagged' (from the @tagged@ +-- package). +newtype Endian (end :: Endianness) a = Endian + { -- | Discard endianness information. + unEndian :: a } + deriving stock (Generic, Data, Show) + deriving (Eq, Ord, Bounded, Num, Enum, Real, Integral) via a + deriving (IsCBLen, Simple.BLen) via a + deriving (Weaken, Strengthen) via a + deriving (ToJSON, FromJSON) via a -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) +-- | Endianness doesn't matter for single bytes. +deriving via Binreply Word8 instance Mason.Put (Endian end Word8) --- 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) +-- | Endianness doesn't matter for single bytes. +deriving via Binreply Word8 instance Flatparse.Get (Endian end Word8) --- | 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 +-- | Endianness doesn't matter for single bytes. +deriving via Binreply Int8 instance Mason.Put (Endian end Int8) --- | 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 +-- | Endianness doesn't matter for single bytes. +deriving via Binreply Int8 instance Flatparse.Get (Endian end Int8) --- | Machine integer sign. -data ISign - = S -- ^ signed - | U -- ^ unsigned - deriving stock (Generic, Data, Show, Eq) +{- 2023-02-01 raehik: +byteswapping should be faster than poking "backwards" byte by byte. confirmed +with nikita-volkov's ptr-poker package via benchmarks (single operation ~2% +faster) and inspecting disassembly (byteswapX is inlined at the assembly level +as BSWAP, byte by byte takes lots of MOVs and SHRs) --- | Machine integer size in number of bytes. -data ISize = I1 | I2 | I4 | I8 - deriving stock (Generic, Data, Show, Eq) +2023-02-18 raehik: this change is applied to nikita-volkov's ptr-poker pkg :) +-} --- | 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 +-- | Ask for a minimum length before running the given parser and wrapping the +-- result in 'Endian'. +flatparseParseEndianMin + :: Flatparse.Getter a -> Int -> Flatparse.Getter (Endian end a) +flatparseParseEndianMin f n = + Endian <$> Flatparse.getEBase f (Flatparse.ERanOut n) --- 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) +instance Bytezap.Put (Endian 'LE Word16) where put = BZ.w16le . unEndian +instance Flatparse.Get (Endian 'LE Word16) where + get = flatparseParseEndianMin FP.anyWord16le 2 +instance Bytezap.Put (Endian 'BE Word16) where put = BZ.w16be . unEndian +instance Flatparse.Get (Endian 'BE Word16) where + get = flatparseParseEndianMin FP.anyWord16be 2 -instance KnownNat (CBLen (I sign size end)) => BLen (I sign size end) where - type CBLen (I sign size end) = CBLen (IRep sign size) +instance Bytezap.Put (Endian 'LE Word32) where put = BZ.w32le . unEndian +instance Flatparse.Get (Endian 'LE Word32) where + get = flatparseParseEndianMin FP.anyWord32le 4 +instance Bytezap.Put (Endian 'BE Word32) where put = BZ.w32be . unEndian +instance Flatparse.Get (Endian 'BE Word32) where + get = flatparseParseEndianMin FP.anyWord32be 4 -instance 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 Bytezap.Put (Endian 'LE Word64) where put = BZ.w64le . unEndian +instance Flatparse.Get (Endian 'LE Word64) where + get = flatparseParseEndianMin FP.anyWord64le 8 +instance Bytezap.Put (Endian 'BE Word64) where put = BZ.w64be . unEndian +instance Flatparse.Get (Endian 'BE Word64) where + get = flatparseParseEndianMin FP.anyWord64be 8 -instance Put (I 'U 'I2 'BE) where put (I i) = Mason.word16BE i -instance Get (I 'U 'I2 'BE) where get = I <$> cutEBase FP.anyWord16be (ERanOut 2) -instance Put (I 'U 'I2 'LE) where put (I i) = Mason.word16LE i -instance Get (I 'U 'I2 'LE) where get = I <$> cutEBase FP.anyWord16le (ERanOut 2) -instance Put (I 'S 'I2 'BE) where put (I i) = Mason.int16BE i -instance Get (I 'S 'I2 'BE) where get = I <$> cutEBase FP.anyInt16be (ERanOut 2) -instance Put (I 'S 'I2 'LE) where put (I i) = Mason.int16LE i -instance Get (I 'S 'I2 'LE) where get = I <$> cutEBase FP.anyInt16le (ERanOut 2) +instance Bytezap.Put (Endian 'LE Int16) where put = BZ.i16le . unEndian +instance Flatparse.Get (Endian 'LE Int16) where + get = flatparseParseEndianMin FP.anyInt16le 2 +instance Bytezap.Put (Endian 'BE Int16) where put = BZ.i16be . unEndian +instance Flatparse.Get (Endian 'BE Int16) where + get = flatparseParseEndianMin FP.anyInt16be 2 -instance Put (I 'U 'I4 'BE) where put (I i) = Mason.word32BE i -instance Get (I 'U 'I4 'BE) where get = I <$> cutEBase FP.anyWord32be (ERanOut 4) -instance Put (I 'U 'I4 'LE) where put (I i) = Mason.word32LE i -instance Get (I 'U 'I4 'LE) where get = I <$> cutEBase FP.anyWord32le (ERanOut 4) -instance Put (I 'S 'I4 'BE) where put (I i) = Mason.int32BE i -instance Get (I 'S 'I4 'BE) where get = I <$> cutEBase FP.anyInt32be (ERanOut 4) -instance Put (I 'S 'I4 'LE) where put (I i) = Mason.int32LE i -instance Get (I 'S 'I4 'LE) where get = I <$> cutEBase FP.anyInt32le (ERanOut 4) +instance Bytezap.Put (Endian 'LE Int32) where put = BZ.i32le . unEndian +instance Flatparse.Get (Endian 'LE Int32) where + get = flatparseParseEndianMin FP.anyInt32le 4 +instance Bytezap.Put (Endian 'BE Int32) where put = BZ.i32be . unEndian +instance Flatparse.Get (Endian 'BE Int32) where + get = flatparseParseEndianMin FP.anyInt32be 4 -instance Put (I 'U 'I8 'BE) where put (I i) = Mason.word64BE i -instance Get (I 'U 'I8 'BE) where get = I <$> cutEBase FP.anyWord64be (ERanOut 8) -instance Put (I 'U 'I8 'LE) where put (I i) = Mason.word64LE i -instance Get (I 'U 'I8 'LE) where get = I <$> cutEBase FP.anyWord64le (ERanOut 8) -instance Put (I 'S 'I8 'BE) where put (I i) = Mason.int64BE i -instance Get (I 'S 'I8 'BE) where get = I <$> cutEBase FP.anyInt64be (ERanOut 8) -instance Put (I 'S 'I8 'LE) where put (I i) = Mason.int64LE i -instance Get (I 'S 'I8 'LE) where get = I <$> cutEBase FP.anyInt64le (ERanOut 8) +instance Bytezap.Put (Endian 'LE Int64) where put = BZ.i64le . unEndian +instance Flatparse.Get (Endian 'LE Int64) where + get = flatparseParseEndianMin FP.anyInt64le 8 +instance Bytezap.Put (Endian 'BE Int64) where put = BZ.i64be . unEndian +instance Flatparse.Get (Endian 'BE Int64) where + get = flatparseParseEndianMin FP.anyInt64be 8 --- | Shortcut. -type family IMax (sign :: ISign) (size :: ISize) :: Natural where - IMax sign size = MaxBound (IRep sign size) +-- | Grouping for matching a signedness and size to a Haskell integer data type. +type family IRep (isign :: ISign) (isize :: Natural) where + IRep 'U 8 = Word8 + IRep 'I 8 = Int8 + IRep 'U 16 = Word16 + IRep 'I 16 = Int16 + IRep 'U 32 = Word32 + IRep 'I 32 = Int32 + IRep 'U 64 = Word64 + IRep 'I 64 = Int64 --- | 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 +-- | Largest representable value for a machine integer made of @n@ bits. +-- +-- If signed ''I', twos complement is used, so negative range has 1 extra value. +type family IMax (isign :: ISign) (n :: Natural) :: Natural where + IMax 'U n = 2^n-1 + IMax 'I n = 2^(n-1) diff --git a/src/Binrep/Type/LenPfx.hs b/src/Binrep/Type/LenPfx.hs deleted file mode 100644 --- a/src/Binrep/Type/LenPfx.hs +++ /dev/null @@ -1,110 +0,0 @@ --- 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 --- a/src/Binrep/Type/Magic.hs +++ b/src/Binrep/Type/Magic.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} -- for weirder type families {- | Magic numbers (also just magic): short constant bytestrings usually found at the top of a file, often used as an early sanity check. -TODO unassociated type fams bad (maybe). turn into class -- and turn the reifier -into a default method! (TODO think about this) - There are two main flavors of magics: * "random" bytes e.g. Zstandard: @28 B5 2F FD@ @@ -28,22 +24,20 @@ import Binrep import Binrep.Type.Byte +import FlatParse.Basic qualified as FP +import Data.ByteString qualified as B 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 - import Strongweak --- | An empty data type representing a magic number (a constant bytestring) via --- a phantom type. +-- | A singleton data type representing a "magic number" (a constant bytestring) +-- via a phantom type. -- --- The phantom type variable unambiguously defines a short, constant bytestring. +-- The phantom type variable unambiguously defines a constant bytestring. -- A handful of types are supported for using magics conveniently, e.g. for pure -- ASCII magics, you may use a 'Symbol' type-level string. data Magic (a :: k) = Magic @@ -54,25 +48,38 @@ -- origins. instance Weaken (Magic a) where type Weak (Magic a) = () - weaken _ = () + weaken Magic = () -- | Strengthen the unit to some 'Magic a'. instance Strengthen (Magic a) where - strengthen _ = pure Magic + strengthen () = pure Magic -instance (KnownNat (Length (MagicBytes a))) => BLen (Magic a) where - type CBLen (Magic a) = Length (MagicBytes a) +instance IsCBLen (Magic a) where type CBLen (Magic a) = Length (MagicBytes a) +deriving via CBLenly (Magic a) instance + KnownNat (Length (MagicBytes a)) => BLen (Magic a) instance (bs ~ MagicBytes a, ReifyBytes bs) => Put (Magic a) where put Magic = reifyBytes @bs -instance (bs ~ MagicBytes a, ReifyBytes bs) => Get (Magic a) where +instance (bs ~ MagicBytes a, ReifyBytes bs, KnownNat (Length bs)) + => Get (Magic a) where + -- TODO silly optimization: we _could_ skip comparing BS lengths because we + -- know they have to be the same. lmao get = do - let expected = Mason.toStrictByteString $ reifyBytes @bs - actual <- FP.takeBs $ B.length expected + -- Nice case where we _want_ flatparse's no-copy behaviour, because + -- 'actual' is only in scope for this parser. Except, of course, if we + -- error, in which case _now_ we copy. Efficient! + actual <- FP.take (blen magic) if actual == expected - then return Magic - else eBase $ EExpected expected actual + then pure Magic + else eBase $ EExpected expected (B.copy actual) + where + expected = runPut magic + magic = Magic :: Magic a + +type family Length (a :: [k]) :: Natural where + Length '[] = 0 + Length (a ': as) = 1 + Length as {- I do lots of functions on lists, because they're structurally simple. But you diff --git a/src/Binrep/Type/Magic/UTF8.hs b/src/Binrep/Type/Magic/UTF8.hs deleted file mode 100644 --- a/src/Binrep/Type/Magic/UTF8.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- | 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 eBase $ EExpected expected actual - -encodeStringUtf8 :: String -> B.ByteString -encodeStringUtf8 = Text.encodeUtf8 . Text.pack diff --git a/src/Binrep/Type/NullPadded.hs b/src/Binrep/Type/NullPadded.hs --- a/src/Binrep/Type/NullPadded.hs +++ b/src/Binrep/Type/NullPadded.hs @@ -3,67 +3,64 @@ module Binrep.Type.NullPadded where import Binrep +import Bytezap.Bytes qualified as BZ +import FlatParse.Basic qualified as FP +import Control.Monad.Combinators qualified as Monad + import Binrep.Util ( tshow ) import Refined import Refined.Unsafe import GHC.TypeNats +import Util.TypeNats ( natValInt ) + 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) +-- | A type which is to be null-padded to a given total length. +-- +-- Given some @a :: 'NullPadded' n a@, it is guaranteed that +-- +-- @ +-- 'blen' a '<=' 'natValInt' \@n +-- @ +-- +-- thus +-- +-- @ +-- 'natValInt' \@n '-' 'blen' a '>=' 0 +-- @ +-- +-- That is, the serialized stored data will not be longer than the total length. +-- +-- The binrep instances are careful not to construct bytestrings unnecessarily. type NullPadded n a = Refined (NullPad n) a -instance KnownNat n => BLen (NullPadded n a) where - -- | The size of some null-padded data is known - at compile time! - type CBLen (NullPadded n a) = n - instance (BLen a, KnownNat n) => Predicate (NullPad n) a where validate p a - | len > n + | len <= n = success + | otherwise = throwRefineOtherException (typeRep p) $ "too long: " <> tshow len <> " > " <> tshow n - | otherwise = success where - n = typeNatToBLen @n + n = natValInt @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) +instance (BLen a, Put a, KnownNat n) => Put (NullPadded n a) where + put ra = put a <> BZ.pokeByteReplicate paddingLen 0x00 where - n = typeNatToBLen @n + a = unrefine ra + paddingLen = natValInt @n - blen a + -- ^ refinement guarantees >=0 --- | 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 +instance (BLen a, Get a, KnownNat n) => Get (NullPadded n a) where get = do a <- get - let len = blen a - nullStrLen = n - len - if nullStrLen < 0 - then eBase $ EOverlong n len - else getNNulls nullStrLen >> return (reallyUnsafeRefine a) - where - n = typeNatToBLen @n - -getNNulls :: BLenT -> Parser E () -getNNulls = \case 0 -> return () - n -> FP.anyWord8 >>= \case - 0x00 -> getNNulls $ n-1 - nonNull -> eBase $ EExpectedByte 0x00 nonNull + let paddingLen = natValInt @n - blen a + if paddingLen < 0 + then eBase $ EFailNamed "TODO used to be EOverlong, cba" + else do + Monad.skipCount paddingLen (FP.word8 0x00) + pure $ reallyUnsafeRefine a diff --git a/src/Binrep/Type/NullTerminated.hs b/src/Binrep/Type/NullTerminated.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/NullTerminated.hs @@ -0,0 +1,69 @@ +{- | C-style null-terminated data. + +I mix string and bytestring terminology here, due to bad C influences. This +module is specifically interested in bytestrings and their encoding. String/text +encoding is handled in 'Binrep.Type.Text'. +-} + +{-# LANGUAGE OverloadedStrings #-} -- for refined errors + +module Binrep.Type.NullTerminated where + +import Binrep + +import Binrep.Get.Flatparse qualified as Flatparse +import FlatParse.Basic qualified as FP + +import Refined +import Refined.Unsafe +import Data.Typeable ( typeRep ) + +import Data.ByteString qualified as B +import Data.Word ( Word8 ) + +-- | Null-terminated data. Arbitrary length terminated with a null byte. +-- Permits no null bytes inside the data. +data NullTerminate +type NullTerminated = Refined NullTerminate + +-- | Null-terminated data may not contain any null bytes. +instance NullCheck a => Predicate NullTerminate a where + validate p a + | hasNoNulls a = throwRefineOtherException (typeRep p) $ + "null byte not permitted in null-terminated data" + | otherwise = success + +class NullCheck a where hasNoNulls :: a -> Bool +instance NullCheck B.ByteString where + {-# INLINE hasNoNulls #-} + hasNoNulls = B.any (== 0x00) + +instance BLen a => BLen (NullTerminated a) where + blen ra = 1 + blen (unrefine ra) + {-# INLINE blen #-} + +-- | Serialization of null-terminated data may be defined generally using the +-- data's underlying serializer. +instance Put a => Put (NullTerminated a) where + {-# INLINE put #-} + put a = put (unrefine a) <> put @Word8 0x00 + +-- | Parse a null-terminated bytestring. +instance Flatparse.Get (NullTerminated B.ByteString) where + {-# INLINE get #-} + get = reallyUnsafeRefine <$> Flatparse.getEBase FP.anyCString (EFailNamed "cstring") + +{- +I don't know how to do @[a]@. Either I nullterm each element, which is weird +because it's not required in all cases, or I don't, in which case the general +Put doesn't work. Nullterming every element feels weird anyway -- what about +[Word8]? + +instance NullCheck a => NullCheck [a] where + {-# INLINE hasNoNulls #-} + hasNoNulls = all hasNoNulls +instance NullCheck Word8 where + {-# INLINE hasNoNulls #-} + hasNoNulls = \case 0x00 -> False + _ -> True +-} diff --git a/src/Binrep/Type/Prefix.hs b/src/Binrep/Type/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic + +module Binrep.Type.Prefix where + +import Binrep.Type.Int +import GHC.TypeNats +import Data.Word + +import Data.Kind + +-- | Types which may be used as prefixes. +-- +-- Generally, these will be integer types. +-- +-- Note that this is separate to binary representation, so endianness is +-- irrelevant. +-- +-- TODO oops can't use 'Int's everywhere because of overflow :'( that's OK +class Prefix a where + type Max a :: Natural + + -- | used by put. guaranteed that it fits from refined. that is, lenToPfx <= + -- Max. + lenToPfx :: Int -> a + + -- | used by get. better not lie. + pfxToLen :: a -> Int + +-- | Length prefixing with the unit means a length of 0. +-- +-- This is the only sensible case. 1 doesn't work because refining checks @<=@. +-- +-- I think there are laws here, where using this is the same as doing nothing at +-- all. +instance Prefix () where + type Max () = 0 + lenToPfx 0 = () + lenToPfx _ = error "you lied to refine and broke everything :(" + pfxToLen () = 0 + +deriving via (a :: Type) instance Prefix a => Prefix (Endian end a) + +instance Prefix Word8 where + type Max Word8 = 2^8 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral +instance Prefix Word16 where + type Max Word16 = 2^16 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral +instance Prefix Word32 where + type Max Word32 = 2^32 - 1 + lenToPfx = fromIntegral + pfxToLen = fromIntegral + +-- TODO no instances > Int, since they would break when too large diff --git a/src/Binrep/Type/Prefix/Count.hs b/src/Binrep/Type/Prefix/Count.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix/Count.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE UndecidableInstances #-} -- required for type-level stuff +{-# LANGUAGE OverloadedStrings #-} -- required for refined errors + +module Binrep.Type.Prefix.Count where + +import Binrep.Type.Prefix +import Binrep +import Control.Monad.Combinators qualified as Monad + +import GHC.TypeNats +import Util.TypeNats ( natValInt ) +import Refined hiding ( Weaken(..), strengthen ) +import Refined.Unsafe ( reallyUnsafeRefine1 ) + +import Data.Typeable ( Typeable, typeRep ) +import Data.Kind + +import Data.Foldable qualified as Foldable + +data CountPrefix (pfx :: Type) +type CountPrefixed pfx = Refined1 (CountPrefix pfx) + +instance (KnownNat (Max pfx), Foldable f, Typeable pfx) + => Predicate1 (CountPrefix pfx) f where + validate1 p fa + | Foldable.length fa <= natValInt @(Max pfx) = success + | otherwise = throwRefineOtherException (typeRep p) "TODO bad" + +instance (KnownNat (Max pfx), Foldable f, Typeable pfx) + => Predicate (CountPrefix pfx) (f a) where + validate = validate1 + +-- TODO no idea if this is sensible +instance IsCBLen (CountPrefixed pfx f a) where + type CBLen (CountPrefixed pfx f a) = CBLen pfx + CBLen (f a) + +instance (Prefix pfx, Foldable f, BLen pfx, BLen (f a)) + => BLen (CountPrefixed pfx f a) where + blen rfa = blen (lenToPfx @pfx (Foldable.length fa)) + blen fa + where fa = unrefine1 rfa + +instance (Prefix pfx, Foldable f, Put pfx, Put (f a)) + => Put (CountPrefixed pfx f a) where + put rfa = put (lenToPfx @pfx (Foldable.length fa)) <> put fa + where fa = unrefine1 rfa + +class GetCount f where getCount :: Get a => Int -> Getter (f a) +instance GetCount [] where getCount n = Monad.count n get + +instance (Prefix pfx, GetCount f, Get pfx, Get a) + => Get (CountPrefixed pfx f a) where + get = do + pfx <- get @pfx + fa <- getCount (pfxToLen pfx) + pure $ reallyUnsafeRefine1 fa diff --git a/src/Binrep/Type/Prefix/Size.hs b/src/Binrep/Type/Prefix/Size.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix/Size.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE UndecidableInstances #-} -- required for type-level stuff +{-# LANGUAGE OverloadedStrings #-} -- required for refined errors + +module Binrep.Type.Prefix.Size where + +import Binrep.Type.Prefix +import Binrep.Type.Thin +import Binrep +import FlatParse.Basic qualified as FP + +import GHC.TypeNats +import Util.TypeNats ( natValInt ) +import Data.ByteString qualified as B +import Refined hiding ( Weaken(..), strengthen ) +import Refined.Unsafe + +import Data.Typeable ( Typeable, typeRep ) +import Data.Kind + +data SizePrefix (pfx :: Type) +type SizePrefixed pfx = Refined (SizePrefix pfx) + +instance (KnownNat (Max pfx), BLen a, Typeable pfx) + => Predicate (SizePrefix pfx) a where + validate p a + | blen a <= natValInt @(Max pfx) = Nothing + | otherwise = throwRefineOtherException (typeRep p) $ + "thing too big for length prefix type" + +-- TODO no idea if this is sensible +instance IsCBLen (SizePrefixed pfx a) where + type CBLen (SizePrefixed pfx a) = CBLen pfx + CBLen a + +instance (Prefix pfx, BLen a, BLen pfx) + => BLen (SizePrefixed pfx a) where + blen ra = blen (lenToPfx @pfx (blen a)) + blen a + where a = unrefine ra + +instance (Prefix pfx, BLen a, Put pfx, Put a) + => Put (SizePrefixed pfx a) where + put ra = put (lenToPfx @pfx (blen a)) <> put a + where a = unrefine ra + +class GetSize a where getSize :: Int -> Getter a +instance GetSize B.ByteString where getSize = fmap B.copy . FP.take +instance GetSize (Thin B.ByteString) where getSize = fmap Thin . FP.take + +instance (Prefix pfx, GetSize a, Get pfx) + => Get (SizePrefixed pfx a) where + get = do + pfx <- get @pfx + a <- getSize (pfxToLen pfx) + pure $ reallyUnsafeRefine a diff --git a/src/Binrep/Type/Sized.hs b/src/Binrep/Type/Sized.hs --- a/src/Binrep/Type/Sized.hs +++ b/src/Binrep/Type/Sized.hs @@ -5,38 +5,39 @@ module Binrep.Type.Sized where import Binrep +import FlatParse.Basic qualified as FP + import Binrep.Util ( tshow ) import Refined import Refined.Unsafe +import Data.Typeable ( typeRep ) import GHC.TypeNats -import Data.Typeable ( typeRep ) -import FlatParse.Basic qualified as FP +import Util.TypeNats ( natValInt ) +-- | Essentially reflects a 'BLen' type to 'CBLen'. data Size (n :: Natural) - -type Sized n a = Refined (Size n) a - -instance KnownNat n => BLen (Sized n a) where type CBLen (Sized n a) = n +type Sized n = Refined (Size n) instance (BLen a, KnownNat n) => Predicate (Size n) a where validate p a - | len > n + | len /= n = throwRefineOtherException (typeRep p) $ "not correctly sized: "<>tshow len<>" /= "<>tshow n | otherwise = success where - n = typeNatToBLen @n + n = natValInt @n len = blen a +instance IsCBLen (Sized n a) where type CBLen (Sized n a) = n +deriving via CBLenly (Sized n a) instance KnownNat n => BLen (Sized n a) + 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 + a <- FP.isolate (natValInt @n) get + pure $ reallyUnsafeRefine a diff --git a/src/Binrep/Type/Text.hs b/src/Binrep/Type/Text.hs --- a/src/Binrep/Type/Text.hs +++ b/src/Binrep/Type/Text.hs @@ -1,193 +1,53 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} +{- TODO 2023-02-15 raehik +Encoding shouldn't change to a bytestring, for efficiency. Due to convenient +representations, we can efficiently serialize a Text directly to a builder, +skipping intermediate ByteString conversion. +Hm. Maybe that means it should be changed to the builder. What does that mean +for decoding? +-} + module Binrep.Type.Text - ( Encoding(..) - , AsText - , Encode, encode + ( AsText + , Encode(..), encode, encodeToRep , Decode(..) - , encodeToRep -#ifdef HAVE_ICU - , decodeViaTextICU -#endif - ) 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 - -#ifdef HAVE_ICU -import Data.Text.ICU.Convert qualified as ICU -#endif - -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 + , module Binrep.Type.Text.Encoding.Utf8 + , module Binrep.Type.Text.Encoding.Ascii + , module Binrep.Type.Text.Encoding.Utf16 + , module Binrep.Type.Text.Encoding.Utf32 + , module Binrep.Type.Text.Encoding.ShiftJis --- | 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 + ) where -instance Encode 'UTF8 where encode' = Text.encodeUtf8 +import Binrep.Type.Text.Internal --- | 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 +import Refined -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 +import Binrep.Type.Text.Encoding.Utf8 +import Binrep.Type.Text.Encoding.Ascii +import Binrep.Type.Text.Encoding.Utf16 +import Binrep.Type.Text.Encoding.Utf32 +import Binrep.Type.Text.Encoding.ShiftJis -- | 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 - --------------------------------------------------------------------------------- --- 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") +-- >>> let Right t = refine @UTF8 (Text.pack "hi") -- >>> :t t --- t :: AsText 'UTF8 +-- t :: AsText UTF8 -- >>> let Right bs = encodeToRep @'C t -- >>> :t bs -- bs :: Refined 'C Bytes encodeToRep - :: forall (rep :: Rep) enc + :: forall 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 - --------------------------------------------------------------------------------- --- ICU - -#ifdef HAVE_ICU -instance Encode 'SJIS where encode' = encodeViaTextICU' "Shift-JIS" -instance Decode 'SJIS where - decode = decodeText id $ decodeViaTextICU' "Shift-JIS" - --- | Encode some 'Text' to the given character set using text-icu. --- --- No guarantees about correctness. Encodings are weird. e.g. Shift JIS's --- 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 -#endif diff --git a/src/Binrep/Type/Text/Encoding/Ascii.hs b/src/Binrep/Type/Text/Encoding/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Ascii.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Binrep.Type.Text.Encoding.Ascii where + +import Binrep.Type.Text.Internal +import Binrep.Type.Text.Encoding.Utf8 + +import Refined +import Data.Typeable ( typeRep ) + +import Data.Char qualified as Char +import Data.Text qualified as Text +import Data.Text ( Text ) + +import Data.Text.Encoding qualified as Text +import Control.Exception qualified +import System.IO.Unsafe qualified + +-- | 7-bit +data Ascii + +-- | We reuse UTF-8 encoding for ASCII, since it is a subset of UTF-8. +instance Encode Ascii where encode' = encode' @Utf8 + +-- Pre-@text-2.0@, @decodeASCII@ generated a warning and ran @decodeUtf8@. +-- TODO can I give some compile time warning about this instance missing on +-- below text-2.0?? would be cool +#if MIN_VERSION_text(2,0,0) +-- TODO 2023-01-26 raehik: awful UX by text. hopefully safe lol?? works at least +instance Decode Ascii where decode = decodeText id $ catchErrorCall Text.decodeASCII +#endif + +catchErrorCall :: (a -> b) -> a -> Either String b +catchErrorCall f a = System.IO.Unsafe.unsafeDupablePerformIO $ do + Control.Exception.try @Control.Exception.ErrorCall (Control.Exception.evaluate (f a)) >>= \case + Right b -> pure $ Right b + Left (Control.Exception.ErrorCallWithLocation msg _) -> pure $ Left msg + +-- | 'Text' must be validated if you want to permit 7-bit ASCII only. +-- +-- TODO there should be a MUCH faster check here in text-2.0. text-short has it, +-- text doesn't yet. see: https://github.com/haskell/text/issues/496 +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" diff --git a/src/Binrep/Type/Text/Encoding/ShiftJis.hs b/src/Binrep/Type/Text/Encoding/ShiftJis.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/ShiftJis.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} + +module Binrep.Type.Text.Encoding.ShiftJis where + +import Refined + +import Data.Text ( Text ) + +#ifdef HAVE_ICU +import Data.Text.ICU.Convert qualified as ICU +import System.IO.Unsafe qualified +import Data.ByteString qualified as B + +import Binrep.Type.Text.Internal +#endif + +data ShiftJis + +-- | TODO Unsafely assume all 'Text's are valid Shift-JIS. +instance Predicate ShiftJis Text where validate _ _ = success + +#ifdef HAVE_ICU +instance Encode ShiftJis where encode' = encodeViaTextICU' "Shift-JIS" +instance Decode ShiftJis where + decode = decodeText id $ decodeViaTextICU' "Shift-JIS" + +-- | Encode some 'Text' to the given character set using text-icu. +-- +-- No guarantees about correctness. Encodings are weird. e.g. Shift JIS's +-- 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 + pure $ 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 + pure $ Right $ ICU.toUnicode conv t + +decodeViaTextICU' :: String -> B.ByteString -> Either String Text +decodeViaTextICU' charset t = do + System.IO.Unsafe.unsafeDupablePerformIO $ decodeViaTextICU charset t +#endif diff --git a/src/Binrep/Type/Text/Encoding/Utf16.hs b/src/Binrep/Type/Text/Encoding/Utf16.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf16.hs @@ -0,0 +1,21 @@ +module Binrep.Type.Text.Encoding.Utf16 where + +import Binrep.Type.Text.Internal +import Binrep.Type.Common ( Endianness(..) ) + +import Refined +import Data.Typeable ( Typeable ) + +import Data.Text.Encoding qualified as Text +import Data.Text ( Text ) + +data Utf16 (end :: Endianness) + +instance Encode (Utf16 'BE) where encode' = Text.encodeUtf16BE +instance Encode (Utf16 'LE) where encode' = Text.encodeUtf16LE + +instance Decode (Utf16 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16BE +instance Decode (Utf16 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf16LE + +-- | Any 'Text' value is always valid UTF-16. +instance Typeable end => Predicate (Utf16 end) Text where validate _ _ = success diff --git a/src/Binrep/Type/Text/Encoding/Utf32.hs b/src/Binrep/Type/Text/Encoding/Utf32.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf32.hs @@ -0,0 +1,21 @@ +module Binrep.Type.Text.Encoding.Utf32 where + +import Binrep.Type.Text.Internal +import Binrep.Type.Common ( Endianness(..) ) + +import Refined +import Data.Typeable ( Typeable ) + +import Data.Text.Encoding qualified as Text +import Data.Text ( Text ) + +data Utf32 (end :: Endianness) + +instance Encode (Utf32 'BE) where encode' = Text.encodeUtf32BE +instance Encode (Utf32 'LE) where encode' = Text.encodeUtf32LE + +instance Decode (Utf32 'BE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32BE +instance Decode (Utf32 'LE) where decode = decodeText show $ wrapUnsafeDecoder Text.decodeUtf32LE + +-- | Any 'Text' value is always valid UTF-32. +instance Typeable end => Predicate (Utf32 end) Text where validate _ _ = success diff --git a/src/Binrep/Type/Text/Encoding/Utf8.hs b/src/Binrep/Type/Text/Encoding/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf8.hs @@ -0,0 +1,16 @@ +module Binrep.Type.Text.Encoding.Utf8 where + +import Binrep.Type.Text.Internal + +import Refined + +import Data.Text.Encoding qualified as Text +import Data.Text ( Text ) + +data Utf8 + +instance Encode Utf8 where encode' = Text.encodeUtf8 +instance Decode Utf8 where decode = decodeText show Text.decodeUtf8' + +-- | Any 'Text' value is always valid UTF-8. +instance Predicate Utf8 Text where validate _ _ = success diff --git a/src/Binrep/Type/Text/Internal.hs b/src/Binrep/Type/Text/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Internal.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Binrep.Type.Text.Internal where + +import Data.Text ( Text ) +import Data.ByteString qualified as B +import Refined +import Refined.Unsafe ( reallyUnsafeRefine ) + +import System.IO.Unsafe qualified +import Control.Exception qualified +import Data.Text.Encoding.Error qualified +import Data.Bifunctor ( bimap ) + +type Bytes = B.ByteString + +-- | A string of a given encoding, stored in the 'Text' type. +-- +-- Essentially 'Text' carrying a proof that it can be successfully encoded into +-- the given encoding. For example, @'AsText' 'ASCII'@ means the 'Text' stored +-- is pure ASCII. +type AsText enc = Refined enc Text + +-- | Bytestring encoders for text validated for a given encoding. +class Encode enc where + -- | Encode text to bytes. Internal function, use 'encode'. + encode' :: Text -> Bytes + +class Decode enc 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) + +-------------------------------------------------------------------------------- +-- 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 = bimap 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 diff --git a/src/Binrep/Type/Thin.hs b/src/Binrep/Type/Thin.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Thin.hs @@ -0,0 +1,55 @@ +{- | "Thin" types which reference the parser input when gotten via 'Get'. + +flatparse's @take@ family perform no copying-- instead, a bytestring is +manually constructed with the finalizer from the input bytestring. I'm not sure +I want this -- it sounds like a memory leak waiting to happen -- so I default to +copying to a new bytestring. This type allows recovering the efficient no-copy +behaviour. + +TODO doing this the other way around would be simpler, and fit flatparse better. +All we need is such a class: + +@ +class Copy a where copy :: a -> a +instance Copy B.ByteString where copy = B.copy +@ + +But this just doesn't fly, because it would invert the behaviour. + +-} + +{-# LANGUAGE UndecidableInstances #-} -- for strongweak derivingvia + +module Binrep.Type.Thin where + +import Binrep + +import FlatParse.Basic qualified as FP +import Bytezap qualified as BZ +import Bytezap.Bytes qualified as BZ + +import GHC.Generics ( Generic ) +import Data.Data ( Data ) +import GHC.Exts ( IsList ) +import Data.String +import Control.DeepSeq +import Data.Functor.Identity +import Strongweak + +import Data.ByteString qualified as B + +newtype Thin a = Thin { unThin :: a } + -- derive all instances that 'Data.ByteString.ByteString' has + deriving stock (Generic, Data, Show, Read) + deriving + ( Eq, Ord, Semigroup, Monoid -- simple + , NFData, IsString, IsList -- weird + , BLen, Put -- binrep + ) via a + + -- at the end of the day, we are the identity functor + deriving (Weaken, Strengthen) via Identity a + +instance Get (Thin B.ByteString) where get = Thin <$> FP.takeRest +instance Get (Thin BZ.Write) where + get = fmap Thin $ fmap BZ.byteString $ FP.takeRest diff --git a/src/Binrep/Type/Varint.hs b/src/Binrep/Type/Varint.hs deleted file mode 100644 --- a/src/Binrep/Type/Varint.hs +++ /dev/null @@ -1,136 +0,0 @@ -{- | Variable-length integers (varints), a method to store arbitrarily large - integers in a space efficient manner. - -Note that varints aren't particularly efficient due to their decoding being -slow. They are most interesting when you wish to provide support for large -integers, but know that many (most?) inputs will be small, and want to be space -efficient for them. Protocol Buffers uses them extensively, while Cap'n Proto -swears them off. - -TODO - - * https://en.wikipedia.org/wiki/Variable-length_quantity - * I've defined basic unsigned varints. Signed varints have lots of options. - You can use twos comp, zigzag, a sign bit, whatever. --} - -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Binrep.Type.Varint where - -import Binrep -import Binrep.Type.Common ( Endianness(..) ) - -import Data.Bits -import FlatParse.Basic qualified as FP - -import Data.Word ( Word8 ) - --- | A variable-length unsigned integer (natural). --- --- The base algorithm is to split the natural into groups of 7 bits, and use the --- MSB to indicate whether another octet follows. You must specify a handful of --- type variables, which select precise varint behaviour beyond this. See their --- documentation for details. --- --- You may select the type to use varnats at, but error handling isn't provided: --- negatives won't work correctly, and overflow cannot be detected. So most of --- the time, you probably want 'Natural' and 'Integer'. --- --- Some examples: --- --- * @'Varnat' ''Redundant' ''OnContinues' ''BE' matches VLQ. --- * @'Varnat' ''Redundant' ''OnContinues' ''LE' matches LEB128, protobuf. --- * @'Varnat' ''Bijective' ''OnContinues' ''LE' matches Git's varints. --- * @'Varnat' ''Bijective' ''OffContinues' ''LE' matches BPS's varints. -newtype Varnat (enc :: Encoding) (cont :: ContinuationBitBehaviour) (e :: Endianness) i = Varnat { getVarnat :: i } - deriving (Eq, Ord, Enum, Num, Real, Integral) via i - deriving stock Show - -data ContinuationBitBehaviour - = OnContinues - -- ^ on=continue, off=end - - | OffContinues - -- ^ on=end, off=continue - -data Encoding - = Redundant - -- ^ simple, some varints have the same value - - | Bijective - -- ^ each integer has exactly 1 varint encoding - --- | VLQ (cont=on) -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'BE i) where - get = go (0 :: i) - where - go i = do - w8 <- FP.anyWord8 - let i' = unsafeShiftL i 7 .|. fromIntegral (clearBit w8 7) - if testVarintCont @cont w8 7 then go i' else pure (Varnat i') - --- | TODO nothing to test against - unsure if correct -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'BE i) where - get = go (0 :: i) - where - go i = do - w8 <- FP.anyWord8 - let i' = unsafeShiftL i 7 .|. (fromIntegral (clearBit w8 7) + 1) - if testVarintCont @cont w8 7 then go i' else pure (Varnat (i'-1)) - --- | protobuf (cont=on), LEB128 (cont=on) --- --- not truly infinite length since shifters take 'Int', but practically infinite -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'LE i) where - get = go (0 :: i) (0 :: Int) - where - go i n = do - w8 <- FP.anyWord8 - let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7)) n - if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat i') - --- | Git varint (cont=on), BPS (beat patches) (cont=off) -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'LE i) where - get = go (0 :: i) (0 :: Int) - where - go i n = do - w8 <- FP.anyWord8 - let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7) + 1) n - if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat (i'-1)) - --- TODO uses fromIntegral's overflow behaviour -instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'LE i) where - put (Varnat i) = do - if i < 0b10000000 then - put @Word8 $ fromIntegral i - else - put @Word8 (setVarintCont @cont (fromIntegral i) 7) - <> put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7)) - --- TODO BE. Hard. -instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'BE i) where - put (Varnat i) = do - if i < 0b10000000 then - put @Word8 $ fromIntegral i - else - put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7)) - <> put @Word8 (setVarintCont @cont (fromIntegral (i .&. 0b11111111)) 7) - --------------------------------------------------------------------------------- - -class VarintContinuation (cont :: ContinuationBitBehaviour) where - varintContinue :: Bool -instance VarintContinuation 'OnContinues where varintContinue = True -instance VarintContinuation 'OffContinues where varintContinue = False - -testVarintCont - :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> Bool -testVarintCont a n = case varintContinue @cont of True -> b - False -> not b - where b = testBit a n - -setVarintCont - :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> a -setVarintCont = case varintContinue @cont of True -> setBit - False -> clearBit diff --git a/src/Binrep/Type/Vector.hs b/src/Binrep/Type/Vector.hs deleted file mode 100644 --- a/src/Binrep/Type/Vector.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | 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 - -instance BLen a => BLen (Vector n a) where - type CBLen (Vector n a) = CBLen a * n - blen = V.sum . V.map blen - -instance Put a => Put (Vector n a) where - 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/Util/Class.hs b/src/Binrep/Util/Class.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/Class.hs @@ -0,0 +1,19 @@ +module Binrep.Util.Class where + +import GHC.TypeLits + +-- | Common type error string for when you attempt to use a binrep instance at +-- an empty data type (e.g. 'Data.Void.Void', 'GHC.Generics.V1'). +type ENoEmpty = 'Text "No binary representation for empty data type" + +-- | Common type error string for when you attempt to use a binrep instance +-- at a sum data type +-- GHC is asked to derive a non-sum +-- instance, but the data type in question turns out to be a sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type ENoSum = + 'Text "No binary representation for unannotated sum data type" + :$$: 'Text "Consider defining a custom data type" + :<>: 'Text " and deriving a generic instance with explicit sum handling" diff --git a/src/Binrep/Util/Generic.hs b/src/Binrep/Util/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/Generic.hs @@ -0,0 +1,19 @@ +module Binrep.Util.Generic where + +import GHC.TypeLits + +-- | Common type error string for when GHC is asked to derive a non-sum +-- instance, but the data type in question turns out to be a sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type EUnexpectedSum = + 'Text "Cannot derive non-sum binary representation instance for sum data type" + +-- | Common type error string for when GHC is asked to derive a sum instance, +-- but the data type in question turns out to be a non-sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type EUnexpectedNonSum = + 'Text "Refusing to derive sum binary representation instance for non-sum data type" diff --git a/src/Binrep/Via.hs b/src/Binrep/Via.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Via.hs @@ -0,0 +1,12 @@ +module Binrep.Via where + +import Binrep.CBLen qualified as BR +import Binrep.BLen.Simple qualified as BR.Simple +import Binrep.Put.Mason qualified as BR.Mason +import Binrep.Put.Bytezap qualified as BR.Bytezap +import Binrep.Get.Flatparse qualified as BR.Flatparse + +-- | Identity newtype for using with @DerivingVia@. +newtype Binreply a = Binreply { unBinreply :: a } + deriving stock Show + deriving (BR.IsCBLen, BR.Simple.BLen, BR.Mason.Put, BR.Bytezap.Put, BR.Flatparse.Get) via a diff --git a/src/Bytezap.hs b/src/Bytezap.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE UnboxedTuples #-} + +module Bytezap where + +import GHC.Exts +import Data.ByteString qualified as B +import Data.ByteString.Internal qualified as B +import GHC.IO +import Data.Word + +-- | TODO inner poke type +-- +-- TODO can I change this to +-- +-- @ +-- Ptr Word8 -> IO (Ptr Word8) +-- @ +-- +-- without any performance loss? it's the same underneath newtypes and datas. +-- 'Ptr' is a data rather than a newtype, but IO is just a newtype. +-- +-- I originally did this to beat ptr-poker, but idk. Now doubtful. +type Poke# = Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) + +-- | Unboxed poke operation. +-- +-- A newtype allows us a monoidal interface. +newtype Poke = Poke + { -- | Write at an offset from an address and return the next offset. + -- + -- The returned offset must be after the argument offset. + -- + -- TODO I use that output order because it matches IO. Probs doesn't matter. + unPoke :: Poke# + } + +-- | Construct a 'Poke'. +poke :: Poke# -> Poke +poke = Poke +{-# INLINE poke #-} + +-- | Sequence two 'Poke's left-to-right. +instance Semigroup Poke where + {-# INLINE (<>) #-} + Poke l <> Poke r = Poke $ \addr# st# -> + case l addr# st# of (# st'#, addr'# #) -> r addr'# st'# + +-- | The empty 'Poke' simply returns its arguments. +instance Monoid Poke where + {-# INLINE mempty #-} + mempty = Poke $ \addr# st# -> (# st#, addr# #) + +-- | Allocate a buffer of the given size and run a 'Poke' over it. +-- +-- The 'Poke' must fill the buffer exactly. If it goes under, you should get +-- some random garbage at the end. If it goes over, your computer will probably +-- explode. +runPoke :: Int -> Poke -> B.ByteString +runPoke len = B.unsafeCreate len . wrapPoke +{-# INLINE runPoke #-} + +wrapPoke :: Poke -> Ptr Word8 -> IO () +wrapPoke (Poke p) (Ptr addr#) = + IO (\st# -> case p addr# st# of (# l, _r #) -> (# l, () #)) +{-# INLINE wrapPoke #-} + +-- | Instructions on how to perform a sized write. +-- +-- The 'Poke' in 'writePoke' must write the _exact_ number of bytes specified in +-- 'writeSize'. Otherwise, your computer explodes. +data Write = Write + { writeSize :: {-# UNPACK #-} !Int + , writePoke :: !Poke -- unpack unusable TODO is strict good or not here + } + +-- | Construct a 'Write'. +write :: Int -> Poke# -> Write +write len p = Write len (Poke p) +{-# INLINE write #-} + +-- | Sequence the 'Poke's, sum the sizes. +instance Semigroup Write where + -- TODO feels like this might be INLINE[1] or even INLINE[0]? + {-# INLINE (<>) #-} + Write ll lp <> Write rl rp = Write (ll + rl) (lp <> rp) + +-- | The empty 'Write' is the empty 'Poke', which writes zero bytes. +instance Monoid Write where + {-# INLINE mempty #-} + mempty = Write 0 mempty + +-- | Serialize and show the resulting ByteString. +instance Show Write where showsPrec p = showsPrec p . runWrite + +runWrite :: Write -> B.ByteString +runWrite (Write len p) = runPoke len p +{-# INLINE runWrite #-} diff --git a/src/Bytezap/Bytes.hs b/src/Bytezap/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Bytes.hs @@ -0,0 +1,41 @@ +-- | 'ByteString's and primitive byte arrays. + +{-# LANGUAGE UnboxedTuples #-} + +module Bytezap.Bytes where + +import Bytezap + +import GHC.Exts +import Data.ByteString qualified as B +import Data.ByteString.Internal qualified as B +import GHC.IO +import Data.Word +import Foreign.ForeignPtr + +byteString :: B.ByteString -> Write +byteString (B.BS fptr len) = Write len (pokeForeignPtr fptr len) +{-# INLINE byteString #-} + +pokeForeignPtr :: ForeignPtr Word8 -> Int -> Poke +pokeForeignPtr fptr len@(I# len#) = poke $ \addr# st# -> + case unIO (memcpyForeignPtr (Ptr addr#) fptr len) st# of + (# st'#, () #) -> (# st'#, addr# `plusAddr#` len# #) +{-# INLINE pokeForeignPtr #-} + +memcpyForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () +memcpyForeignPtr ptrTo fptrFrom len = + B.unsafeWithForeignPtr fptrFrom $ \ptrFrom -> B.memcpy ptrTo ptrFrom len +{-# INLINE memcpyForeignPtr #-} + +pokeByteArray# :: ByteArray# -> Int# -> Int# -> Poke +pokeByteArray# arr# off# len# = poke $ \addr# st# -> + case copyByteArrayToAddr# arr# off# addr# len# st# of + st'# -> (# st'#, addr# `plusAddr#` len# #) +{-# INLINE pokeByteArray# #-} + +-- TODO this seems to work but like, really? wow lol +pokeByteReplicate :: Int -> Word8 -> Poke +pokeByteReplicate n@(I# n#) w8 = poke $ \addr# st# -> + case unIO (B.memset (Ptr addr#) w8 (fromIntegral n)) st# of + (# st'#, _ #) -> (# st'#, addr# `plusAddr#` n# #) diff --git a/src/Bytezap/Class.hs b/src/Bytezap/Class.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Class.hs @@ -0,0 +1,51 @@ +module Bytezap.Class where + +import Bytezap +import Bytezap.Bytes qualified as W +import Bytezap.Int qualified as W + +import Data.ByteString ( ByteString ) +import Data.Word +import Data.Int + +class Put a where put :: a -> Write + +instance Put Write where + {-# INLINE put #-} + put = id + +instance Put ByteString where + {-# INLINE put #-} + put = W.byteString + +instance Put Word8 where + {-# INLINE put #-} + put = W.w8 + +instance Put Word16 where + {-# INLINE put #-} + put = W.w16 + +instance Put Word32 where + {-# INLINE put #-} + put = W.w32 + +instance Put Word64 where + {-# INLINE put #-} + put = W.w64 + +instance Put Int8 where + {-# INLINE put #-} + put = W.i8 + +instance Put Int16 where + {-# INLINE put #-} + put = W.i16 + +instance Put Int32 where + {-# INLINE put #-} + put = W.i32 + +instance Put Int64 where + {-# INLINE put #-} + put = W.i64 diff --git a/src/Bytezap/Int.hs b/src/Bytezap/Int.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Int.hs @@ -0,0 +1,158 @@ +-- | Sized machine integers. + +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +module Bytezap.Int where + +import Bytezap +--import Bytezap.Prim.Integer qualified as Prim +import GHC.Exts +import Data.Word +import GHC.Word +import Data.Int +import GHC.Int + +w8 :: Word8 -> Write +w8 (W8# a#) = write 1 $ \addr# st# -> + case writeWord8OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 1# #) +{-# INLINE w8 #-} + +w16 :: Word16 -> Write +w16 (W16# a#) = write 2 $ \addr# st# -> + case writeWord16OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 2# #) +{-# INLINE w16 #-} + +w32 :: Word32 -> Write +w32 (W32# a#) = write 4 $ \addr# st# -> + case writeWord32OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 4# #) +{-# INLINE w32 #-} + +w64 :: Word64 -> Write +w64 (W64# a#) = write 8 $ \addr# st# -> + case writeWord64OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE w64 #-} + +{-# INLINE w16le #-} +{-# INLINE w16be #-} +w16le, w16be :: Word16 -> Write +#ifdef WORDS_BIGENDIAN +w16le = w16 . byteSwap16 +w16be = w16 +#else +w16le = w16 +w16be = w16 . byteSwap16 +#endif + +{-# INLINE w32le #-} +{-# INLINE w32be #-} +w32le, w32be :: Word32 -> Write +#ifdef WORDS_BIGENDIAN +w32le = w32 . byteSwap32 +w32be = w32 +#else +w32le = w32 +w32be = w32 . byteSwap32 +#endif + +{-# INLINE w64le #-} +{-# INLINE w64be #-} +w64le, w64be :: Word64 -> Write +#ifdef WORDS_BIGENDIAN +w64le = w64 . byteSwap64 +w64be = w64 +#else +w64le = w64 +w64be = w64 . byteSwap64 +#endif + +i8 :: Int8 -> Write +i8 (I8# a#) = write 1 $ \addr# st# -> + case writeInt8OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 1# #) +{-# INLINE i8 #-} + +i16 :: Int16 -> Write +i16 (I16# a#) = write 2 $ \addr# st# -> + case writeInt16OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 2# #) +{-# INLINE i16 #-} + +i32 :: Int32 -> Write +i32 (I32# a#) = write 4 $ \addr# st# -> + case writeInt32OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 4# #) +{-# INLINE i32 #-} + +i64 :: Int64 -> Write +i64 (I64# a#) = write 8 $ \addr# st# -> + case writeInt64OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE i64 #-} + +byteSwapI16 :: Int16 -> Int16 +byteSwapI16 = undefined + +byteSwapI32 :: Int32 -> Int32 +byteSwapI32 = undefined + +byteSwapI64 :: Int64 -> Int64 +byteSwapI64 = undefined + +{-# INLINE i16le #-} +{-# INLINE i16be #-} +i16le, i16be :: Int16 -> Write +#ifdef WORDS_BIGENDIAN +i16le = i16 . byteSwapI16 +i16be = i16 +#else +i16le = i16 +i16be = i16 . byteSwapI16 +#endif + +{-# INLINE i32le #-} +{-# INLINE i32be #-} +i32le, i32be :: Int32 -> Write +#ifdef WORDS_BIGENDIAN +i32le = i32 . byteSwapI32 +i32be = i32 +#else +i32le = i32 +i32be = i32 . byteSwapI32 +#endif + +{-# INLINE i64le #-} +{-# INLINE i64be #-} +i64le, i64be :: Int64 -> Write +#ifdef WORDS_BIGENDIAN +i64le = i64 . byteSwapI64 +i64be = i64 +#else +i64le = i64 +i64be = i64 . byteSwapI64 +#endif + +-- TODO assumes 64-bit +int# :: Int# -> Write +int# a# = write 8 $ \addr# st# -> + case writeIntOffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE int# #-} + +{- + +-- | Construct a 'Write' of the following length using the given primitive poke. +writeViaPrim + :: Int# + -> (forall s. Addr# -> Int# -> a -> State# s -> State# s) + -> a -> Write +writeViaPrim len# writeOffPrim a = write (I# len#) $ \addr# os# st# -> + case writeOffPrim addr# os# a st# of + st'# -> (# st'#, os# +# len# #) +{-# INLINE writeViaPrim #-} + +-} diff --git a/src/Bytezap/Poke/Bytes.hs b/src/Bytezap/Poke/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Poke/Bytes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE UnboxedTuples #-} + +module Bytezap.Poke.Bytes where + +import Bytezap + +import GHC.Exts +import Data.ByteString qualified as B +import Data.ByteString.Internal qualified as B +import GHC.IO +import Data.Word +import Foreign.ForeignPtr + +byteString :: B.ByteString -> Poke +byteString (B.BS fptr len) = pokeForeignPtr fptr len +{-# INLINE byteString #-} + +pokeForeignPtr :: ForeignPtr Word8 -> Int -> Poke +pokeForeignPtr fptr len@(I# len#) = poke $ \addr# st# -> + case unIO (memcpyForeignPtr (Ptr addr#) fptr len) st# of + (# st'#, () #) -> (# st'#, addr# `plusAddr#` len# #) +{-# INLINE pokeForeignPtr #-} + +memcpyForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () +memcpyForeignPtr ptrTo fptrFrom len = + B.unsafeWithForeignPtr fptrFrom $ \ptrFrom -> B.memcpy ptrTo ptrFrom len +{-# INLINE memcpyForeignPtr #-} + +pokeByteArray# :: ByteArray# -> Int# -> Int# -> Poke +pokeByteArray# arr# off# len# = poke $ \addr# st# -> + case copyByteArrayToAddr# arr# off# addr# len# st# of + st'# -> (# st'#, addr# `plusAddr#` len# #) +{-# INLINE pokeByteArray# #-} diff --git a/src/Bytezap/Poke/Int.hs b/src/Bytezap/Poke/Int.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Poke/Int.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +module Bytezap.Poke.Int where + +import Bytezap +import GHC.Exts +import Data.Word +import GHC.Word +import Data.Int +import GHC.Int + +w8 :: Word8 -> Poke +w8 (W8# a#) = Poke $ \addr# st# -> + case writeWord8OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 1# #) +{-# INLINE w8 #-} + +w16 :: Word16 -> Poke +w16 (W16# a#) = Poke $ \addr# st# -> + case writeWord16OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 2# #) +{-# INLINE w16 #-} + +w32 :: Word32 -> Poke +w32 (W32# a#) = Poke $ \addr# st# -> + case writeWord32OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 4# #) +{-# INLINE w32 #-} + +w64 :: Word64 -> Poke +w64 (W64# a#) = Poke $ \addr# st# -> + case writeWord64OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE w64 #-} + +{-# INLINE w16le #-} +{-# INLINE w16be #-} +w16le, w16be :: Word16 -> Poke +#ifdef WORDS_BIGENDIAN +w16le = w16 . byteSwap16 +w16be = w16 +#else +w16le = w16 +w16be = w16 . byteSwap16 +#endif + +{-# INLINE w32le #-} +{-# INLINE w32be #-} +w32le, w32be :: Word32 -> Poke +#ifdef WORDS_BIGENDIAN +w32le = w32 . byteSwap32 +w32be = w32 +#else +w32le = w32 +w32be = w32 . byteSwap32 +#endif + +{-# INLINE w64le #-} +{-# INLINE w64be #-} +w64le, w64be :: Word64 -> Poke +#ifdef WORDS_BIGENDIAN +w64le = w64 . byteSwap64 +w64be = w64 +#else +w64le = w64 +w64be = w64 . byteSwap64 +#endif + +i8 :: Int8 -> Poke +i8 (I8# a#) = Poke $ \addr# st# -> + case writeInt8OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 1# #) +{-# INLINE i8 #-} + +i16 :: Int16 -> Poke +i16 (I16# a#) = Poke $ \addr# st# -> + case writeInt16OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 2# #) +{-# INLINE i16 #-} + +i32 :: Int32 -> Poke +i32 (I32# a#) = Poke $ \addr# st# -> + case writeInt32OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 4# #) +{-# INLINE i32 #-} + +i64 :: Int64 -> Poke +i64 (I64# a#) = Poke $ \addr# st# -> + case writeInt64OffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE i64 #-} + +byteSwapI16 :: Int16 -> Int16 +byteSwapI16 = undefined + +byteSwapI32 :: Int32 -> Int32 +byteSwapI32 = undefined + +byteSwapI64 :: Int64 -> Int64 +byteSwapI64 = undefined + +{-# INLINE i16le #-} +{-# INLINE i16be #-} +i16le, i16be :: Int16 -> Poke +#ifdef WORDS_BIGENDIAN +i16le = i16 . byteSwapI16 +i16be = i16 +#else +i16le = i16 +i16be = i16 . byteSwapI16 +#endif + +{-# INLINE i32le #-} +{-# INLINE i32be #-} +i32le, i32be :: Int32 -> Poke +#ifdef WORDS_BIGENDIAN +i32le = i32 . byteSwapI32 +i32be = i32 +#else +i32le = i32 +i32be = i32 . byteSwapI32 +#endif + +{-# INLINE i64le #-} +{-# INLINE i64be #-} +i64le, i64be :: Int64 -> Poke +#ifdef WORDS_BIGENDIAN +i64le = i64 . byteSwapI64 +i64be = i64 +#else +i64le = i64 +i64be = i64 . byteSwapI64 +#endif + +-- TODO assumes 64-bit +int# :: Int# -> Poke +int# a# = Poke $ \addr# st# -> + case writeIntOffAddr# addr# 0# a# st# of + st'# -> (# st'#, addr# `plusAddr#` 8# #) +{-# INLINE int# #-} diff --git a/src/Bytezap/Text.hs b/src/Bytezap/Text.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Text.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +module Bytezap.Text where + +import Bytezap +import Bytezap.Int + +import Data.Text.Internal + +-- unused import warnings due to messy CPP +import Bytezap.Bytes +import Data.Text.Array qualified as A +import GHC.Exts + +import Data.Char ( ord ) +import Data.Foldable ( foldl' ) +import Data.Bits ( shiftR, (.&.) ) + +textUtf8 :: Text -> Write +{-# INLINE textUtf8 #-} +#if MIN_VERSION_text(2,0,0) +textUtf8 (Text (A.ByteArray arr#) (I# off#) len@(I# len#)) = + Write len $ pokeByteArray# arr# off# len# +#else +textUtf8 = error "Bytezap.Text.textUtf8: cba for text-1" +#endif + +-- TODO adapted from utf8-string +charUtf8 :: Char -> Write +charUtf8 = go . ord + where + go oc + | oc <= 0x7f = w8 $ fromIntegral oc + + | oc <= 0x7ff = w8 (fromIntegral (0xc0 + (oc `shiftR` 6))) + <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) + + | oc <= 0xffff = w8 (fromIntegral (0xe0 + (oc `shiftR` 12))) + <> w8 (fromIntegral (0x80 + ((oc `shiftR` 6) .&. 0x3f))) + <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) + | otherwise = w8 (fromIntegral (0xf0 + (oc `shiftR` 18))) + <> w8 (fromIntegral (0x80 + ((oc `shiftR` 12) .&. 0x3f))) + <> w8 (fromIntegral (0x80 + ((oc `shiftR` 6) .&. 0x3f))) + <> w8 (fromIntegral (0x80 + oc .&. 0x3f)) +{-# INLINE charUtf8 #-} + +-- | TODO +-- +-- In a perfect world, functions like this would not exist. But this is not a +-- perfect world. 'String's suck for a number of reasons. One big one is that +-- they are horrendous to serialize. Worse, as of GHC 9.6, type-level strings +-- only reflect to 'String'. This function does the best it can to efficiently +-- serialize 'String's. It would be much easier and probably similarly fast to +-- go through 'Text' instead, but who doesn't like a little challenge? +stringUtf8 :: String -> Write +stringUtf8 = foldl' (\w c -> w <> charUtf8 c) mempty +{-# INLINE stringUtf8 #-} diff --git a/src/Data/Aeson/Extra/SizedVector.hs b/src/Data/Aeson/Extra/SizedVector.hs --- a/src/Data/Aeson/Extra/SizedVector.hs +++ b/src/Data/Aeson/Extra/SizedVector.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Data.Aeson.Extra.SizedVector where +module Data.Aeson.Extra.SizedVector() where import Data.Aeson import Data.Vector.Generic.Sized.Internal qualified as VSI @@ -16,4 +16,4 @@ v <- parseJSON j case VS.toSized v of Nothing -> fail "TODO bad size" - Just v' -> return v' + Just v' -> pure v' diff --git a/src/Haskpatch/Format/Bps.hs b/src/Haskpatch/Format/Bps.hs deleted file mode 100644 --- a/src/Haskpatch/Format/Bps.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Haskpatch.Format.Bps where - -import Binrep.Type.Magic -import Binrep.Type.Sized -import Binrep.Type.Varint -import Binrep.Type.Common -import Strongweak - -import Data.ByteString qualified as B - --- | TODO --- * can't do generic because BPS doesn't store command list length, instead --- requiring a dynamic check on every command --- * wonder if this is better or more efficient that using a 'BpsVarint' for --- the length, same as metadata, or storing the end size as a 'BpsVarint'. --- * maybe two diff types of varint, +ve and -ve. unclear from spec --- * perhaps store the varint type(s) as a type var, to allow switching --- between efficient machine ints and safe 'Integer', 'Natural'! -data Bps (s :: Strength) i a = Bps - { bpsMagic :: SW s (Magic "BPS1") - , bpsSourceSize :: SW s (BpsVarint i) - , bpsTargetSize :: SW s (BpsVarint i) - - , bpsMetadata :: BpsMeta a - -- ^ Optional metadata. According to the specification, this should - -- "officially" be XML version 1.0 encoding UTF-8 data, but anything goes. - - , bpsCommands :: [BpsCommand] - , bpsFooter :: BpsFooter s - } - -type BpsVarint = Varnat 'Bijective 'OffContinues 'LE - -data BpsMeta a - -data BpsCommand - = BpsCommandSourceRead - | BpsCommandTargetRead - | BpsCommandSourceCopy - | BpsCommandTargetCopy - -data BpsFooter (s :: Strength) = BpsFooter - { bpsFooterSourceChecksum :: SW s (Sized 4 B.ByteString) - , bpsFooterTargetChecksum :: SW s (Sized 4 B.ByteString) - , bpsFooterPatchChecksum :: SW s (Sized 4 B.ByteString) - } diff --git a/src/Haskpatch/Format/Vcdiff.hs b/src/Haskpatch/Format/Vcdiff.hs deleted file mode 100644 --- a/src/Haskpatch/Format/Vcdiff.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | https://datatracker.ietf.org/doc/html/rfc3284 - -module Haskpatch.Format.Vcdiff where - -import Binrep.Type.Magic -import Binrep.Type.Varint -import Binrep.Type.Common -import Strongweak - -import Numeric.Natural -import Data.ByteString ( ByteString ) -import Data.Word ( Word8 ) - -data Vcdiff (s :: Strength) = Vcdiff - { vcdiffHeader :: Header s - } - -data Header (s :: Strength) = Header - { headerMagic :: SW s (Magic '[0xD6, 0xC3, 0xC4, 0x00]) - -- ^ First 3 bytes are @VCD@ each with their MSB on. - - , headerIndicator :: SW s (Magic '[0x00]) - -- ^ TODO annoying and impacts rest of format. forcing to 0x00 to simplify - } - -data Window (s :: Strength) = Window - { windowIndicator :: SW s (Magic '[0x00]) -- TODO - , windowDelta :: Delta s - } - -data Delta (s :: Strength) = Delta - { deltaIndicator :: SW s (Magic '[0x00]) -- TODO compression indicators. ignoring - , deltaAddRun :: ByteString - , deltaInstrs :: [InstrCode] - , deltaCopy :: ByteString - } - -data InstrCode = InstrCode - { instrCodeTriple1 :: InstrTriple - , instrCodeTriple2 :: InstrTriple - } - -data InstrTriple = InstrTriple - { instrTripleInstr :: Instr - - , instrTripleSize :: Word8 - - , instrTripleMode :: Word8 - -- ^ 0 and meaningless unless instr is a COPY - } - --- TODO singletons it -data Instr = Instr0Noop | Instr1Add | Instr2Run | Instr3Copy - --- | Apparently from the Sfio library, also similar (but not identical) to BPS's --- varints. -type VcdiffVarint = Varnat 'Redundant 'OnContinues 'BE Natural diff --git a/src/Util/Generic.hs b/src/Util/Generic.hs deleted file mode 100644 --- a/src/Util/Generic.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Util.Generic where - -import GHC.Generics - --- | 'datatypeName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -datatypeName' :: forall d. Datatype d => String -datatypeName' = datatypeName @d undefined - --- | 'conName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -conName' :: forall c. Constructor c => String -conName' = conName @c undefined - --- | 'selName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -selName' :: forall s. Selector s => String -selName' = selName @s undefined - --- | Get the record name for a selector if present. --- --- On the type level, a 'Maybe Symbol' is stored for record names. But the --- reification is done using @fromMaybe ""@. So we have to inspect the resulting --- string to determine whether the field uses record syntax or not. (Silly.) -selName'' :: forall s. Selector s => Maybe String -selName'' = case selName' @s of "" -> Nothing - s -> Just s diff --git a/src/Util/TypeNats.hs b/src/Util/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/Util/TypeNats.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Handy typenat utils. + +module Util.TypeNats where + +-- natVal'' +import GHC.TypeNats ( Natural, KnownNat, natVal' ) +import GHC.Exts ( proxy#, Proxy# ) + +natVal'' :: forall n. KnownNat n => Natural +natVal'' = natVal' (proxy# :: Proxy# n) +{-# INLINE natVal'' #-} + +natValInt :: forall n. KnownNat n => Int +natValInt = fromIntegral $ natVal'' @n +{-# INLINE natValInt #-} + diff --git a/test/ArbitraryOrphans.hs b/test/ArbitraryOrphans.hs --- a/test/ArbitraryOrphans.hs +++ b/test/ArbitraryOrphans.hs @@ -1,10 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} module ArbitraryOrphans() where import Test.QuickCheck ( Arbitrary ) -import Binrep.Type.Int ( I(..), IRep ) +import Binrep.Type.Int +import Data.Kind --- | Machine integers steal their underlying representation's instance. -deriving via (IRep sign size) instance Arbitrary (IRep sign size) => Arbitrary (I sign size e) +-- TODO 2023-01-26 raehik: why does the following crash GHC +deriving via (a :: Type) instance Arbitrary a => Arbitrary (Endian end a) +--deriving newtype instance Arbitrary a => Arbitrary (Endian end a) diff --git a/test/Binrep/LawsSpec.hs b/test/Binrep/LawsSpec.hs --- a/test/Binrep/LawsSpec.hs +++ b/test/Binrep/LawsSpec.hs @@ -10,15 +10,16 @@ import ArbitraryOrphans() import Binrep -import Binrep.Generic +import Binrep.Generic ( nullTermCstrPfxTag ) +import Binrep.BLen.Simple ( blenGenericNonSum, blenGenericSum ) import Binrep.Type.Int import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.ByteString -import Data.Word ( Word8 ) +import Binrep.Type.NullTerminated +import Data.Word import Data.ByteString qualified as B import GHC.Generics ( Generic ) -import Control.Exception ( evaluate ) +import Generic.Data.Function.Traverse spec :: Spec spec = do @@ -28,21 +29,12 @@ \(bs :: B.ByteString) -> runGet (runPut bs) `shouldBe` Right (bs, "") prop "parse-print roundtrip isomorphism (generic, sum tag via nullterm constructor)" $ do \(d :: D) -> runGet (runPut d) `shouldBe` Right (d, "") - prop "serializing a type with an incorrect generic derivation throws an exception" $ do - \(d :: DNoSum) -> do - let evaluateShouldThrow a = evaluate a `shouldThrow` (\case EDerivedSumInstanceWithNonSumCfg -> True) - evaluateShouldThrow (blen d) - evaluateShouldThrow (runPut d) - prop "parsing a type with an incorrect generic derivation fails" $ do - \(bs :: B.ByteString) -> do - let e = EGeneric "DNoSum" $ EGenericSum $ EGenericSumTag $ EBase ENoVoid - runGet @DNoSum bs `shouldBe` Left e -------------------------------------------------------------------------------- -type W1 = (I 'U 'I1 'LE) -type W2LE = (I 'U 'I2 'LE) -type W8BE = (I 'U 'I8 'BE) +type W1 = Word8 +type W2LE = Endian 'LE Word16 +type W8BE = Endian 'BE Word64 data D = D01Bla Word8 W1 W8BE @@ -52,18 +44,14 @@ deriving stock (Generic, Eq, Show) deriving via (GenericArbitraryU `AndShrinking` D) instance Arbitrary D -dCfg :: Cfg (AsByteString 'C) -dCfg = cfg cSumTagNullTerm - -instance BLen D where blen = blenGeneric dCfg -instance Put D where put = putGeneric dCfg -instance Get D where get = getGeneric dCfg +instance BLen D where blen = blenGenericSum $ blen . nullTermCstrPfxTag +instance Put D where put = putGenericSum $ put . nullTermCstrPfxTag +instance Get D where get = getGenericSum $ eqShowPfxTagCfg nullTermCstrPfxTag data DNoSum = DNoSum Word8 W1 W2LE W8BE - | DNoSumBad deriving stock (Generic, Eq, Show) deriving via (GenericArbitraryU `AndShrinking` DNoSum) instance Arbitrary DNoSum -instance BLen DNoSum where blen = blenGeneric cNoSum -instance Put DNoSum where put = putGeneric cNoSum -instance Get DNoSum where get = getGeneric cNoSum +instance BLen DNoSum where blen = blenGenericNonSum +instance Put DNoSum where put = putGenericNonSum +instance Get DNoSum where get = getGenericNonSum