binrep 0.3.1 → 0.5.0

raw patch · 68 files changed

+2808/−2535 lines, 68 filesdep +deepseqdep +gaugedep +generic-data-functionsdep −eitherdep −refineddep ~aesondep ~bytestringdep ~flatparsePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, gauge, generic-data-functions, parser-combinators, refined1

Dependencies removed: either, refined

Dependency ranges changed: aeson, bytestring, flatparse, hspec, megaparsec, strongweak, text, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +24/−13
• bench/Main.hs +303/−0
• binrep.cabal +101/−94
• src/Binrep.hs +14/−22
• src/Binrep/BLen.hs +0/−111
• src/Binrep/BLen/Internal/AsBLen.hs +0/−65
• src/Binrep/BLen/Simple.hs +120/−0
• src/Binrep/CBLen.hs +23/−0
• src/Binrep/CBLen/Generic.hs +71/−0
• src/Binrep/Example.hs +0/−65
• src/Binrep/Example/FileTable.hs +0/−105
• src/Binrep/Example/Tar.hs +0/−61
• src/Binrep/Example/Tiff.hs +0/−58
• src/Binrep/Example/Wav.hs +0/−27
• src/Binrep/Extra/HexByteString.hs +1/−1
• src/Binrep/Generic.hs +9/−72
• src/Binrep/Generic/BLen.hs +0/−52
• src/Binrep/Generic/CBLen.hs +0/−70
• src/Binrep/Generic/Get.hs +0/−87
• src/Binrep/Generic/Internal.hs +0/−17
• src/Binrep/Generic/Put.hs +0/−67
• src/Binrep/Get.hs +0/−145
• src/Binrep/Get/Flatparse.hs +268/−0
• src/Binrep/Put.hs +0/−69
• src/Binrep/Put/Bytezap.hs +99/−0
• src/Binrep/Put/Mason.hs +102/−0
• src/Binrep/Type/AsciiNat.hs +0/−110
• src/Binrep/Type/Byte.hs +275/−291
• src/Binrep/Type/ByteString.hs +0/−100
• src/Binrep/Type/Common.hs +2/−2
• src/Binrep/Type/Int.hs +110/−109
• src/Binrep/Type/LenPfx.hs +0/−110
• src/Binrep/Type/Magic.hs +28/−21
• src/Binrep/Type/Magic/UTF8.hs +0/−47
• src/Binrep/Type/NullPadded.hs +38/−41
• src/Binrep/Type/NullTerminated.hs +69/−0
• src/Binrep/Type/Prefix.hs +56/−0
• src/Binrep/Type/Prefix/Count.hs +55/−0
• src/Binrep/Type/Prefix/Size.hs +53/−0
• src/Binrep/Type/Sized.hs +13/−12
• src/Binrep/Type/Text.hs +26/−166
• src/Binrep/Type/Text/Encoding/Ascii.hs +47/−0
• src/Binrep/Type/Text/Encoding/ShiftJis.hs +55/−0
• src/Binrep/Type/Text/Encoding/Utf16.hs +21/−0
• src/Binrep/Type/Text/Encoding/Utf32.hs +21/−0
• src/Binrep/Type/Text/Encoding/Utf8.hs +16/−0
• src/Binrep/Type/Text/Internal.hs +55/−0
• src/Binrep/Type/Thin.hs +55/−0
• src/Binrep/Type/Varint.hs +0/−136
• src/Binrep/Type/Vector.hs +0/−25
• src/Binrep/Util/Class.hs +19/−0
• src/Binrep/Util/Generic.hs +19/−0
• src/Binrep/Via.hs +12/−0
• src/Bytezap.hs +97/−0
• src/Bytezap/Bytes.hs +41/−0
• src/Bytezap/Class.hs +51/−0
• src/Bytezap/Int.hs +158/−0
• src/Bytezap/Poke/Bytes.hs +33/−0
• src/Bytezap/Poke/Int.hs +141/−0
• src/Bytezap/Text.hs +58/−0
• src/Data/Aeson/Extra/SizedVector.hs +2/−2
• src/Haskpatch/Format/Bps.hs +0/−46
• src/Haskpatch/Format/Vcdiff.hs +0/−57
• src/Util/Generic.hs +0/−29
• src/Util/TypeNats.hs +18/−0
• test/ArbitraryOrphans.hs +5/−4
• test/Binrep/LawsSpec.hs +14/−26

@@ -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 

@@ -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.

@@ -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+    ]+  ]

@@ -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

@@ -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.+-}

@@ -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

@@ -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 #-}

@@ -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 #-}

@@ -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

@@ -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+

@@ -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

@@ -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-  ]

@@ -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

@@ -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]

@@ -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

@@ -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.

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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++-}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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+-}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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"

@@ -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

@@ -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 #-}

@@ -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# #)

@@ -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

@@ -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 #-}++-}

@@ -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# #-}

@@ -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# #-}

@@ -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 #-}

@@ -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'

@@ -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)-  }

@@ -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

@@ -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

@@ -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 #-}+

@@ -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)

@@ -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