packages feed

binrep 0.3.1 → 1.1.0

raw patch · 73 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,51 @@+## 1.1.0 (2025-03-11)+* remove strongweak integration+  * to be released in separate package binrep-instances+* update rerefined++## 1.0.0 (2024-10-03)+* fix `NullTerminate` check being inverted (OOPS LOL)+* fix `Get [a]` instance (list backwards xd)+* add type-level constructor parsing for generics (!!)+* rewrite `AsciiNat`+* switch from refined to rerefined (my refined rewrite)+* add missing `BLen (GenericallyNonSum a)` instance+* other various cleanup++## 0.8.0 (2024-04-13)+* add missing `And` predicate combinators instances (`PutC`, `GetC`)+* add `Type.Derived.NullTermPadded` (type synonym over `And`)+* add `Generically` instances for `PutC` and `GetC`, where only non-sums are+  permitted+* add `GenericallyNonSum` newtype wrapper+* `Magic (a :: Symbol)` now supports UTF-8 symbols instead of just ASCII. All+  work is still done on the type-level.++## 0.7.0 (2024-04-10)+* provide "C struct" parser (from bytezap)+* fill out some missing C struct instances+* speed up magic parsing (sped up serializing in v0.6.0)+* add special binrep instances for `And` predicate combinator which re-associate+  to wrap the left predicate in the right+  * this gives a clean solution to the null-padded null-terminated bytestring,+    and appears to be generally sound! felt great to discover+* add Generically instances for C struct parser/serializers+  * can't for regular parser/serializer because of sum/non-sum choice++## 0.6.0 (2024-04-05)+* many updates to parsing/serializing internals, including generics+* provide "C struct" serializer++## 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
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2022 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>+Copyright (c) 2022-2025 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
README.md view
@@ -1,24 +1,26 @@-[gh-strongweak]: https://github.com/raehik/strongweak-[gh-flatparse]:  https://github.com/AndrasKovacs/flatparse-[gh-mason]:      https://github.com/fumieval/mason-[gh-refined]:    https://github.com/nikita-volkov/refined+[gh-strongweak]:   https://github.com/raehik/strongweak+[gh-flatparse]:    https://github.com/AndrasKovacs/flatparse+[gh-mason]:        https://github.com/fumieval/mason+[gh-refined]:      https://github.com/nikita-volkov/refined+[hackage-gdf]:     https://hackage.haskell.org/package/generic-data-functions+[hackage-bytezap]: https://hackage.haskell.org/package/bytezap  # 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+low-context byte-oriented file formats e.g. C enums, 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-    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.+  * **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.+  * **Low boilerplate:** Free performant parsers and serializers via generics.+    _(See [Generic binary representation](#generic-binary-representation).)_+  * **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+    [bytezap][hackage-bytezap] and [flatparse][gh-flatparse].  ## Usage ### Dependencies@@ -63,26 +65,28 @@ supporting definitions for this pattern, and generic derivers which will work with binrep's binary representation primitives. -### Performant primitives-Parsing uses András Kovács' [flatparse][gh-flatparse] library. Serializing is-via Fumiaki Kinoshita's [mason][gh-mason] library. These are about as fast as-you can get in 2022.--We only define serializers for validated types, meaning we can potentially skip-safety checks, that other serializers would do. Except we still do them, but-validation is an explicitly required step before serialization.--*This might change if we start to support weirder binary representations,-specifically offset-based data.*- ## Generic binary representation-binrep's generic deriving makes very few decisions:+_(Generics are now handled by [generic-data-functions][hackage-gdf]. This info+is largely the same, but the code is elsewhere.)_ +binrep includes powerful generics for automatically writing instances.+They all work the same way:+   * Constructors are encoded by sequentially encoding every enclosed field.     * Empty constructors thus serialize to 0 bytes.-  * Sum types are encoded via a tag obtained from the constructor names.-    * It's the same approach as aeson, with a bit more flexibility: see below.+  * For sum types, the constructor is disambiguated via a tag obtained from the+    constructor name.+    * Tags may be parsed on the type or term level. +Note that when parsing sum types, we compare tags sequentially. You may design+your tag schema to have a more efficient approach. In such cases, consider using+`Generic.Data.FOnCstr` from [generic-data-functions][hackage-gdf].++As an example, you could encode constructor names as a null-terminated ASCII+bytestring for a tag. (This is provided at `Binrep.Generic.nullTermCstrPfxTag`.)+Alternatively, you may encode each constructor at a unique byte value, stated at+the end of the constructor name.+ Sum types (data types with multiple constructors) are handled by first encoding a "tag field", the value of which then indicates which constructor to use. You must provide a function to convert from a constructor name to a (unique) tag.@@ -139,3 +143,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.
+ bench/Main.hs view
@@ -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 $ blen . nullTermCstrPfxTag+instance Put  X3 where put  =  putGenericSum $  put . nullTermCstrPfxTag++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+    ]+  ]
binrep.cabal view
@@ -1,14 +1,14 @@ 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.36.1. -- -- see: https://github.com/sol/hpack  name:           binrep-version:        0.3.1+version:        1.1.0 synopsis:       Encode precise binary representations directly in types description:    Please see README.md.-category:       Data, Serialization+category:       Data, Serialization, Generics homepage:       https://github.com/raehik/binrep#readme bug-reports:    https://github.com/raehik/binrep/issues author:         Ben Orchard@@ -17,7 +17,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC ==9.2.4+    GHC==9.8 extra-source-files:     README.md     CHANGELOG.md@@ -35,162 +35,173 @@   exposed-modules:       Binrep       Binrep.BLen-      Binrep.BLen.Internal.AsBLen-      Binrep.Example-      Binrep.Example.FileTable-      Binrep.Example.Tar-      Binrep.Example.Tiff-      Binrep.Example.Wav-      Binrep.Extra.HexByteString+      Binrep.CBLen+      Binrep.Common.Class.TypeErrors+      Binrep.Common.Via.Generically.NonSum+      Binrep.Common.Via.Prim+      Binrep.Example.Sum+      Binrep.Example.Tga       Binrep.Generic-      Binrep.Generic.BLen-      Binrep.Generic.CBLen-      Binrep.Generic.Get-      Binrep.Generic.Internal-      Binrep.Generic.Put       Binrep.Get+      Binrep.Get.Error+      Binrep.Get.Struct       Binrep.Put+      Binrep.Put.Struct       Binrep.Type.AsciiNat-      Binrep.Type.Byte-      Binrep.Type.ByteString-      Binrep.Type.Common-      Binrep.Type.Int-      Binrep.Type.LenPfx+      Binrep.Type.Derived.NullTermPadded       Binrep.Type.Magic-      Binrep.Type.Magic.UTF8       Binrep.Type.NullPadded+      Binrep.Type.NullTerminated+      Binrep.Type.Prefix.Count+      Binrep.Type.Prefix.Internal+      Binrep.Type.Prefix.Size       Binrep.Type.Sized       Binrep.Type.Text-      Binrep.Type.Varint-      Binrep.Type.Vector-      Binrep.Util-      Data.Aeson.Extra.SizedVector-      Haskpatch.Format.Bps-      Haskpatch.Format.Vcdiff-      Util.Generic+      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.ByteOrder+      Binrep.Util.Generic+      Raehik.Compat.FlatParse.Basic.CutWithPos+      Raehik.Compat.FlatParse.Basic.Prim+      Raehik.Compat.FlatParse.Basic.Remaining+      Raehik.Compat.FlatParse.Basic.WithLength+      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+  ghc-options: -fhide-source-paths -Wall   build-depends:-      aeson ==2.0.*-    , base >=4.14 && <5-    , bytestring ==0.11.*-    , either >=5.0.1.1 && <5.1-    , flatparse >=0.3.5.0 && <0.4-    , mason >=0.2.5 && <0.3-    , megaparsec >=9.2.0 && <9.3-    , refined ==0.7.*-    , strongweak >=0.3.1 && <0.4-    , text >=1.2 && <2.1-    , vector >=0.12.3.1 && <0.13-    , vector-sized >=1.5.0 && <1.6+      base >=4.18 && <5+    , bytestring >=0.11 && <0.13+    , bytezap >=1.6.0 && <1.7+    , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*+    , flatparse >=0.5.0.2 && <0.6+    , generic-data-functions >=0.6.0 && <0.7+    , generic-type-asserts >=0.3.0 && <0.4+    , generic-type-functions >=0.1.0 && <0.2+    , ghc-bignum ==1.3.*+    , parser-combinators >=1.3.0 && <1.4+    , rerefined >=0.8.0 && <0.9+    , text >=2.0 && <2.2+    , text-builder-linear >=0.1.3 && <0.2+    , type-level-bytestrings >=0.1.0 && <0.3+    , type-level-show >=0.3.0 && <0.4+  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   main-is: Spec.hs   other-modules:       ArbitraryOrphans-      Binrep.Extra.HexByteStringSpec-      Binrep.LawsSpec+      Binrep.GenericSpec+      Binrep.TypesSpec       Paths_binrep   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+  ghc-options: -fhide-source-paths -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.*-    , base >=4.14 && <5+    , base >=4.18 && <5     , binrep-    , bytestring ==0.11.*-    , either >=5.0.1.1 && <5.1-    , flatparse >=0.3.5.0 && <0.4+    , bytestring >=0.11 && <0.13+    , bytezap >=1.6.0 && <1.7+    , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*+    , flatparse >=0.5.0.2 && <0.6+    , generic-data-functions >=0.6.0 && <0.7     , generic-random >=1.5.0.1 && <1.6-    , hspec >=2.7 && <2.10-    , mason >=0.2.5 && <0.3-    , megaparsec >=9.2.0 && <9.3+    , generic-type-asserts >=0.3.0 && <0.4+    , generic-type-functions >=0.1.0 && <0.2+    , ghc-bignum ==1.3.*+    , hspec >=2.7 && <2.12+    , 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-    , vector-sized >=1.5.0 && <1.6+    , rerefined >=0.8.0 && <0.9+    , text >=2.0 && <2.2+    , text-builder-linear >=0.1.3 && <0.2+    , type-level-bytestrings >=0.1.0 && <0.3+    , type-level-show >=0.3.0 && <0.4+  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: -fhide-source-paths -Wall+  build-depends:+      base >=4.18 && <5+    , binrep+    , bytestring >=0.11 && <0.13+    , bytezap >=1.6.0 && <1.7+    , deepseq >=1.4.6.1 && <1.6+    , defun-core ==0.1.*+    , flatparse >=0.5.0.2 && <0.6+    , gauge+    , generic-data-functions >=0.6.0 && <0.7+    , generic-type-asserts >=0.3.0 && <0.4+    , generic-type-functions >=0.1.0 && <0.2+    , ghc-bignum ==1.3.*+    , parser-combinators >=1.3.0 && <1.4+    , rerefined >=0.8.0 && <0.9+    , text >=2.0 && <2.2+    , text-builder-linear >=0.1.3 && <0.2+    , type-level-bytestrings >=0.1.0 && <0.3+    , type-level-show >=0.3.0 && <0.4+  default-language: GHC2021+  if flag(icu)+    cpp-options: -DHAVE_ICU+    build-depends:+        text-icu >=0.7.0.0 && <0.9
src/Binrep.hs view
@@ -1,26 +1,79 @@-{- | Main end-user binrep module bundling most functionality.+{- | Top-level binrep module, exporting all classes, generics & runners. -Generics are bundled together in 'Binrep.Generic'.+binrep helps you precisely model binary schemas by combining simple "building+blocks" (e.g. @'Binrep.Type.NullTerminated.NullTerminated' a@) in regular+Haskell types. You can then receive high-performance serializers and parsers for+free via generics.++binrep is /not/ a general-purpose parsing/serializing library. For that, see++  * mason, for fast and flexible serializing+  * flatparse, for extremely performant parsing+  * bytezap, for overly-fast serializing and parsing (but very limited) -}  module Binrep-  ( module Binrep.BLen+  (+  -- * Class and instance design+  -- $class-and-instance-design++  -- * Struct parsing & serializing+  -- $struct-handlers+    module Binrep.BLen+  , module Binrep.CBLen   , module Binrep.Put+  , module Binrep.Put.Struct   , module Binrep.Get--  -- * Extras-  , blenViaPut+  , module Binrep.Get.Struct   ) where  import Binrep.BLen+import Binrep.CBLen import Binrep.Put+import Binrep.Put.Struct import Binrep.Get+import Binrep.Get.Struct --- | 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+{- $class-and-instance-design+At the core of binrep are a set of classes defining parsers, serializers, and+serialized length checkers on supported types. binrep is its own ecosystem where+explicitness and correctness win over all:++  * there are no binrep instances for 'Data.Void.Void' or 'GHC.Generics.V1'+    because we can't use them; rather than providing an absurd, possibly+    convenient instance, we emit a type error for their attempted use.+  * you can't put/get 'Data.Word.Word32's etc by themselves; you must provide+    endianness information via the 'Binrep.Util.ByteOrder.ByteOrdered' newtype+  * @'Get' 'Data.ByteString.ByteString'@ just consumes the whole input. seem+    weird? it works with the combinators (it's actually rather important)++Here are some important design decisions:++  * Fields in product types are concatenated left-to-right. e.g. @'Put' (l, r)@+    first puts @l@, then @r@. Nothing is placed between them.+  * Sum types must define how to handle the constructor sum.+    Generics are split into sum handlers and non-sum handlers.+    binrep instances are not provided for types such as @'Either' a b@, where we+    can't state how to choose between the 'Left' and 'Right' constructors.+  * @'Refined.Refined' (pl `Refined.And` pr) a@ is re-associated to+    @'Refined.Refined' pr ('Refined.Refined' pl a)@. The single layer of+    refinements is ergonomic, but the way binrep instances work means we need+    the latter. So 'Refined.And' instances essentially rewrite themselves to+    work as if it were a stack of refinements. (See+    'Binrep.Type.Derived.NullTermPadded' for an example.)+-}++{- $struct-handlers++There are experimental "struct" handlers, which only work on data types that+look like C structs. That is,++  * every field must be constant length, and+  * no sums allowed.++The underlying runners for these are even faster-- they shouldn't do much more+work than the code a C compiler would generate for a similar @struct@. But they+are very inflexible (few binrep instances, hard to write by hand) and poorly+tested. Please be warned when using them. (And do consider sending bug reports+to the author!)+-}
src/Binrep/BLen.hs view
@@ -1,111 +1,144 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableInstances #-} -- for CBLen+{-# LANGUAGE UndecidableInstances #-} -- for 'ViaCBLen', 'TypeError'+{-# LANGUAGE AllowAmbiguousTypes #-} -- for type-level sum type handling +{- | 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.++Note that you _may_ encode this inside the serializer type (whatever the @Put@+class stores). I went back and forth on this a couple times. But some binrep+code seems to make more sense when byte length is standalone. And I don't mind+the extra explicitness. So it's here to stay :)+-}+ module Binrep.BLen-  ( module Binrep.BLen-  , module Binrep.BLen.Internal.AsBLen+  ( BLen(blen)+  , blenGenericNonSum, blenGenericSum, blenGenericSumRaw+  , ViaCBLen(..), cblen   ) where -import Binrep.BLen.Internal.AsBLen-import Binrep.Util ( natVal'' )+import Binrep.CBLen+import GHC.TypeNats -import GHC.TypeLits+import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty )+import GHC.TypeLits ( TypeError ) +import Data.Void import Data.ByteString qualified as B- import Data.Word import Data.Int+import Binrep.Util.ByteOrder -import Data.Void ( Void, absurd )+import Data.Monoid qualified as Monoid+import GHC.Generics+import Generic.Data.Function.FoldMap+import Generic.Data.MetaParse.Cstr ( Raw, ParseCstrTo )+import Generic.Type.Assert+import Binrep.Common.Via.Generically.NonSum -type BLenT = Int+import Rerefined.Refine+import Rerefined.Predicate.Logical.And -{- | 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.+-- | Class for types with easily-calculated length in bytes.+--+-- If it appears hard to calculate byte length for a given type (e.g. without+-- first serializing it, then measuring serialized byte length), consider+-- whether this type is a good fit for binrep.+class BLen a where+    -- | Calculate the serialized byte length of the given value.+    blen :: a -> Int -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.+instance GenericFoldMap BLen where+    type GenericFoldMapM BLen = Monoid.Sum Int+    type GenericFoldMapC BLen a = BLen a+    genericFoldMapF = Monoid.Sum . blen -  * 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.+-- | Measure the byte length of a term of the non-sum type @a@ via its 'Generic'+--   instance.+blenGenericNonSum+    :: forall a+    .  ( Generic a, GFoldMapNonSum BLen (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => a -> Int+blenGenericNonSum = Monoid.getSum . genericFoldMapNonSum @BLen -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.+instance+  ( Generic a, GFoldMapNonSum BLen (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => BLen (GenericallyNonSum a) where+    blen = blenGenericNonSum . unGenericallyNonSum -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+-- | Measure the byte length of a term of the sum type @a@ via its 'Generic'+--   instance.+blenGenericSum+    :: forall sumtag a+    .  ( Generic a, GFoldMapSum BLen sumtag (Rep a)+       , GAssertNotVoid a, GAssertSum a+    ) => ParseCstrTo sumtag Int -> a -> Int+blenGenericSum f =+    Monoid.getSum . genericFoldMapSum @BLen @sumtag (\p -> Monoid.Sum (f p)) -    -- | 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-            )+-- TODO perhaps provide some handy wrappers that fill in blen for sumtag type+-- with cblen? how to do this well? -typeNatToBLen :: forall n. KnownNat n => BLenT-typeNatToBLen = natToBLen $ natVal'' @n-{-# INLINE typeNatToBLen #-}+-- | Measure the byte length of a term of the sum type @a@ via its 'Generic'+--   instance.+blenGenericSumRaw+    :: forall a+    .  ( Generic a, GFoldMapSum BLen Raw (Rep a)+       , GAssertNotVoid a, GAssertSum a+    ) => (String -> Int) -> a -> Int+blenGenericSumRaw f =+    Monoid.getSum . genericFoldMapSumRaw @BLen (Monoid.Sum <$> f) --- | 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 #-}+-- We can't provide a Generically instance because the user must choose between+-- sum and non-sum handlers. --- | Impossible to put a byte length to 'Void'.-instance BLen Void where-    blen = absurd+instance BLen (Refined pr (Refined pl a))+  => BLen (Refined (pl `And` pr) a) where+    blen = blen . unsafeRefine @_ @pr . unsafeRefine @_ @pl . unrefine --- | @O(n)@-instance BLen a => BLen [a] where-    blen = sum . map blen+instance TypeError ENoEmpty => BLen Void where blen = undefined+instance TypeError ENoSum => BLen (Either a b) where blen = undefined -instance (BLen a, BLen b) => BLen (a, b) where-    blen (a, b) = blen a + blen b+-- | _O(1)_ Unit type has length 0.+instance BLen () where blen () = 0 -instance BLen B.ByteString where-    blen = posIntToBLen . B.length+-- | _O(1)_ Sum tuples.+instance (BLen l, BLen r) => BLen (l, r) where blen (l, r) = blen l + blen r -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+-- | _O(n)_ Sum the length of each element of a list.+instance BLen a => BLen [a] where blen = sum . map blen ---------------------------------------------------------------------------------+-- | _O(1)_ 'B.ByteString's store their own length.+instance BLen B.ByteString where blen = B.length --- | 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 }+-- All words have a constant byte length-- including host-size words, mind you!+deriving via ViaCBLen Word8  instance BLen Word8+deriving via ViaCBLen  Int8  instance BLen  Int8+deriving via ViaCBLen Word16 instance BLen Word16+deriving via ViaCBLen  Int16 instance BLen  Int16+deriving via ViaCBLen Word32 instance BLen Word32+deriving via ViaCBLen  Int32 instance BLen  Int32+deriving via ViaCBLen Word64 instance BLen Word64+deriving via ViaCBLen  Int64 instance BLen  Int64 -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+-- | Explicitness does not alter length.+deriving via ViaCBLen (ByteOrdered end a)+    instance KnownNat (CBLen a) => BLen (ByteOrdered end a)++--------------------------------------------------------------------------------++-- | DerivingVia wrapper for types which may derive a 'BLen' instance through+--   an existing 'IsCBLen' instance (i.e. it is known at compile time)+--+-- Examples of such types include machine integers, and explicitly-sized types+-- (e.g. "Binrep.Type.Sized").+newtype ViaCBLen a = ViaCBLen { unViaCBLen :: a }+instance KnownNat (CBLen a) => BLen (ViaCBLen a) where blen _ = cblen @a
− src/Binrep/BLen/Internal/AsBLen.hs 
@@ -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 #-}
+ src/Binrep/CBLen.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE UndecidableInstances #-} -- due to various type algebra+{-# LANGUAGE AllowAmbiguousTypes  #-} -- for reification util++module Binrep.CBLen where++import GHC.TypeNats+import Data.Word+import Data.Int+import Binrep.Util.ByteOrder++import GHC.Exts ( Int#, Int(I#), Proxy# )+import Util.TypeNats ( natValInt )++import DeFun.Core ( type (~>), type App )++import Rerefined.Refine+import Rerefined.Predicate.Logical.And++import Binrep.Common.Class.TypeErrors ( ENoEmpty )++import GHC.Generics+import GHC.TypeError+import Data.Kind ( type Type )++import Data.Type.Equality+import Data.Type.Bool++import Bytezap.Common.Generic ( type GTFoldMapCAddition )++import Binrep.Common.Via.Generically.NonSum++class IsCBLen a where type CBLen a :: Natural++-- | Deriving via this instance necessitates @UndecidableInstances@.+instance Generic a => IsCBLen (GenericallyNonSum a) where+    type CBLen (GenericallyNonSum a) = CBLenGenericNonSum a++instance IsCBLen (Refined pr (Refined pl a))+  =>   IsCBLen (Refined (pl `And` pr) a) where+    type CBLen (Refined (pl `And` pr) a) = CBLen (Refined pr (Refined pl a))++instance (IsCBLen l, IsCBLen r) => IsCBLen (l, r) where+    type CBLen (l, r) = CBLen l + CBLen r++instance IsCBLen () where type CBLen () = 0++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++-- | Endianness does not alter constant length.+deriving via (a :: Type) instance IsCBLen a => IsCBLen (ByteOrdered end a)++-- | Reify a type's constant byte length to the term level.+cblen :: forall a. KnownNat (CBLen a) => Int+cblen = natValInt @(CBLen a)++cblen# :: forall a. KnownNat (CBLen a) => Int#+cblen# = i#+  where !(I# i#) = natValInt @(CBLen a)++cblenProxy# :: forall a. KnownNat (CBLen a) => Proxy# a -> Int#+cblenProxy# _ = i#+  where !(I# i#) = natValInt @(CBLen a)++-- | Defunctionalization symbol for 'CBLen'.+--+-- This is required for parameterized type-level generics e.g. bytezap's+-- 'Bytezap.Struct.Generic.GPokeBase'.+type CBLenSym :: a ~> Natural+data CBLenSym a+type instance App CBLenSym a = CBLen a++{- $generic-cblen++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 may derive a 'CBLen' type generically for a non-sum type with++    instance IsCBLen a where type CBLen a = CBLenGenericNonSum a++You may attempt to derive a 'CBLen' type generically for a sum type with++    instance IsCBLen a where type CBLen a = CBLenGenericSum w a++As with other generic sum type handlers, you must provide the type used to store+the sum tag for sum types. That sum tag type must have a 'CBLen', and every+constructor must have the same 'CBLen' for a 'CBLen' to be calculated. Not many types will fit those criteria, and the code is not well-tested.+-}++-- | Using this necessitates @UndecidableInstances@.+type CBLenGenericSum (w :: Type) a = GCBLen w (Rep a)++-- | Using this necessitates @UndecidableInstances@.+type CBLenGenericNonSum a = GTFoldMapCAddition CBLenSym (Rep a)++type family GCBLen w (gf :: k -> Type) :: Natural where+    GCBLen w (D1 _ gf) = GCBLen w gf+    GCBLen _ V1        = TypeError ENoEmpty+    GCBLen w (l :+: r) = CBLen w + GCBLenCaseMaybe (GCBLenSum (l :+: r))+    GCBLen w (C1 _ gf) = GTFoldMapCAddition CBLenSym gf++--type family GCBLenSum (gf :: k -> Type) :: Maybe Natural where+type family GCBLenSum (gf :: k -> Type) where+    GCBLenSum (C1 ('MetaCons name _ _) gf) =+        JustX (GTFoldMapCAddition CBLenSym gf) name+    GCBLenSum (l :+: r) = MaybeEq (GCBLenSum l) (GCBLenSum 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
+ src/Binrep/Common/Class/TypeErrors.hs view
@@ -0,0 +1,19 @@+module Binrep.Common.Class.TypeErrors 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"
+ src/Binrep/Common/Via/Generically/NonSum.hs view
@@ -0,0 +1,3 @@+module Binrep.Common.Via.Generically.NonSum where++newtype GenericallyNonSum a = GenericallyNonSum { unGenericallyNonSum :: a }
+ src/Binrep/Common/Via/Prim.hs view
@@ -0,0 +1,4 @@+module Binrep.Common.Via.Prim where++-- | DerivingVia newtype for types which can borrow from 'Prim''.+newtype ViaPrim a = ViaPrim { unViaPrim :: a }
− src/Binrep/Example.hs 
@@ -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
− src/Binrep/Example/FileTable.hs 
@@ -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-  ]
+ src/Binrep/Example/Sum.hs view
@@ -0,0 +1,16 @@+module Binrep.Example.Sum where++import Binrep+import Data.Word+import GHC.Generics ( type Generic )+import Generic.Data.FOnCstr++data SumType = SumType1 Word8 | SumType2 Word8 Word8+    deriving stock (Generic, Show)++instance Get SumType where+    get = do+        get @Word8 >>= \case+          1 -> genericFOnCstr @Get @"SumType1"+          2 -> genericFOnCstr @Get @"SumType2"+          _ -> error "TODO"
− src/Binrep/Example/Tar.hs 
@@ -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
+ src/Binrep/Example/Tga.hs view
@@ -0,0 +1,32 @@+module Binrep.Example.Tga where++{-++{-+import Binrep+import Binrep.Type.Derived.NullTermPadded+import Binrep.Type.AsciiNat+import Rerefined+-}+import Strongweak+import Data.Word++data Header (s :: Strength) a = Header+  { idLen :: SW s Word8+  , colorMapType :: ColorMapType+  , imageType :: ImageType+  --, colorMapSpec :: +  --, imageSpec+  }++data ColorMapType = NoColorMap {- ^ 0 -} | HasColorMap {- ^ 1 -}+data ImageType+  = NoImageData+  | UncompColorMapped+  | UncompTrueColor+  | UncompBW+  | RLEColorMapped+  | RLETrueColor+  | RLEBW++-}
− src/Binrep/Example/Tiff.hs 
@@ -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]
− src/Binrep/Example/Wav.hs 
@@ -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
− src/Binrep/Extra/HexByteString.hs 
@@ -1,109 +0,0 @@--- | Pretty bytestrings via printing each byte as two hex digits.------ This is primarily for aeson and when we want better 'show'ing of non-textual--- bytestrings. It's not really binrep-related, but it needs _somewhere_ to go--- and my projects that need it usually also touch binrep, so here it is.------ Sadly, we can't use it to make aeson print integers as hex literals. It only--- deals in Scientifics, and if we tried printing them as strings, it would--- quote them. I need a YAML-like with better literals...--module Binrep.Extra.HexByteString where--import GHC.Generics ( Generic )-import Data.Data ( Data )--import Data.ByteString qualified as B-import Data.ByteString.Short qualified as B.Short-import Data.Char qualified as Char-import Data.Word-import Data.Text qualified as Text-import Data.Text ( Text )-import Data.List as List--import Text.Megaparsec hiding ( parse )-import Text.Megaparsec.Char qualified as MC-import Data.Void--import Data.Aeson---- TODO could add some integer instances to print them as hex too---- No harm in being polymorphic over the byte representation.-newtype Hex a = Hex { unHex :: a }-    deriving stock (Generic, Data)-    deriving Eq via a---- But most users will probably just want this.-type HexByteString = Hex B.ByteString--instance Show (Hex B.ByteString) where-    show = Text.unpack . prettyHexByteString B.unpack . unHex--instance FromJSON (Hex B.ByteString) where-    parseJSON = withText "hex bytestring" $ \t ->-        case parseMaybe @Void (parseHexByteString B.pack) t of-          Nothing -> fail "failed to parse hex bytestring (TODO)"-          Just t' -> pure (Hex t')--instance ToJSON   (Hex B.ByteString) where-    toJSON = String . prettyHexByteString B.unpack . unHex--instance Show (Hex B.Short.ShortByteString) where-    show = Text.unpack . prettyHexByteString B.Short.unpack . unHex--instance FromJSON (Hex B.Short.ShortByteString) where-    parseJSON = withText "hex bytestring" $ \t ->-        case parseMaybe @Void (parseHexByteString B.Short.pack) t of-          Nothing -> fail "failed to parse hex bytestring (TODO)"-          Just t' -> pure (Hex t')--instance ToJSON   (Hex B.Short.ShortByteString) where-    toJSON = String . prettyHexByteString B.Short.unpack . unHex---- | A hex bytestring looks like this: @00 01 89 8a   FEff@. You can mix and--- match capitalization and spacing, but I prefer to space each byte, full caps.-parseHexByteString-    :: (MonadParsec e s m, Token s ~ Char)-    => ([Word8] -> a) -> m a-parseHexByteString pack = pack <$> parseHexByte `sepBy` MC.hspace---- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both--- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid.------ Returns a value 0-255, so can fit in any Num type that can store that.-parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a-parseHexByte = do-    c1 <- MC.hexDigitChar-    c2 <- MC.hexDigitChar-    return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2)---- | Pretty print to default format @00 12 AB FF@: space between each byte, all---   caps.------ This format I consider most human readable. I prefer caps to draw attention--- to this being data instead of text (you don't see that many capital letters--- packed together in prose).-prettyHexByteString :: (a -> [Word8]) -> a -> Text-prettyHexByteString unpack =-      Text.concat-    . List.intersperse (Text.singleton ' ')-    . fmap (f . prettyHexByte Char.toUpper)-    . unpack-  where-    f :: (Char, Char) -> Text-    f (c1, c2) = Text.cons c1 $ Text.singleton c2--prettyHexByte :: (Char -> Char) -> Word8 -> (Char, Char)-prettyHexByte f w = (prettyNibble h, prettyNibble l)-  where-    (h,l) = fromIntegral w `divMod` 0x10-    prettyNibble = f . Char.intToDigit -- Char.intToDigit returns lower case---- | Pretty print to "compact" format @0012abff@ (often output by hashers).-prettyHexByteStringCompact :: (a -> [Word8]) -> a -> Text-prettyHexByteStringCompact unpack =-    Text.concat . fmap (f . prettyHexByte id) . unpack-  where-    f :: (Char, Char) -> Text-    f (c1, c2) = Text.cons c1 $ Text.singleton c2
src/Binrep/Generic.hs view
@@ -1,79 +1,15 @@--- | 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??)"---- | Obtain the tag for a sum type value using the constructor name directly---   (with a null terminator).------ This is probably not what you want in a binary representation, but it's safe--- and may be useful for debugging.------ The refine force is safe under the assumption that Haskell constructor names--- are UTF-8 with no null bytes allowed. I haven't confirmed that, but I'm--- fairly certain.-cSumTagNullTerm :: String -> AsByteString 'C-cSumTagNullTerm = reallyUnsafeRefine . Text.encodeUtf8 . Text.pack---- | Default generic derivation configuration, using 'cSumTagNullTerm'.-cDef :: Cfg (AsByteString 'C)-cDef = cfg cSumTagNullTerm+import Rerefined.Refine ( unsafeRefine ) --- | 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.+-- | Turn a constructor name into a prefix tag by adding a null terminator. ----- 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+-- Not common in binary data representations, but safe and useful for debugging.+nullTermCstrPfxTag :: String -> NullTerminated B.ByteString+nullTermCstrPfxTag = unsafeRefine . Text.encodeUtf8 . Text.pack+-- ^ reallyUnsafeRefine : safe assuming Haskell constructor names are UTF-8 with+-- no null bytes allowed
− src/Binrep/Generic/BLen.hs 
@@ -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)
− src/Binrep/Generic/CBLen.hs 
@@ -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
− src/Binrep/Generic/Get.hs 
@@ -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
− src/Binrep/Generic/Internal.hs 
@@ -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"
− src/Binrep/Generic/Put.hs 
@@ -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
src/Binrep/Get.hs view
@@ -1,129 +1,303 @@-{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-} -- for various stuff+{-# LANGUAGE AllowAmbiguousTypes #-} -- for type-level sum type handling+{-# LANGUAGE OverloadedStrings #-} -- for easy error building  module Binrep.Get-  ( Getter, Get(..), runGet, runGetter-  , E(..), EBase(..), EGeneric(..), EGenericSum(..)-  , eBase-  , getEWrap, getEBase-  , cutEBase-  , GetWith(..), runGetWith+  ( module Binrep.Get+  , module Binrep.Get.Error   ) where +import Binrep.Get.Error+import Data.Text.Builder.Linear qualified as TBL+import GHC.Exts ( fromString )+import Binrep.Util.ByteOrder+import Binrep.Common.Via.Prim ( ViaPrim(..) )+import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf )+import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )++import Binrep.Get.Struct ( GetC(getC), GetterC )+import Bytezap.Parser.Struct qualified as BZ+import Binrep.CBLen ( IsCBLen(CBLen), cblen )+import GHC.TypeLits ( KnownNat )+ import FlatParse.Basic qualified as FP+import Raehik.Compat.FlatParse.Basic.Prim qualified as FP+import Raehik.Compat.FlatParse.Basic.CutWithPos qualified as FP+import Raehik.Compat.FlatParse.Basic.Remaining qualified as FP  import Data.ByteString qualified as B -import GHC.Exts ( TYPE, type LiftedRep )+import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty )+import GHC.TypeLits ( TypeError ) +import GHC.Generics+import Generic.Data.Function.Traverse+import Generic.Data.MetaParse.Cstr ( Raw, ParseCstrTo )+import Generic.Type.Assert++import GHC.Exts ( minusAddr#, Int(I#), Int#, plusAddr#, (+#) )++import Rerefined.Refine+import Rerefined.Predicate.Logical.And+ import Data.Word import Data.Int-import Data.Void ( Void )--import GHC.Generics ( Generic )+import Data.Void+import Binrep.Common.Via.Generically.NonSum -import Data.Text ( Text )+import Generic.Data.FOnCstr+import Generic.Data.Function.Traverse.Constructor hiding ( ENoEmpty )+import GHC.Exts ( Proxy# ) -import Binrep.BLen ( BLenT )+import Data.Typeable ( Typeable, TypeRep, typeRep, Proxy(Proxy) ) -import Numeric.Natural+type Getter = FP.Parser (ParseError FP.Pos TBL.Builder) -type Getter a = FP.Parser E a+class Get a where+    -- | Parse from binary.+    get :: Getter a -data E-  = EBase EBase+runGet+    :: Get a+    => B.ByteString+    -> Either (ParseError Int TBL.Builder) (a, B.ByteString)+runGet = runGetter get -  | EGeneric String {- ^ datatype name -} EGeneric+runGetter+    :: Getter a+    -> B.ByteString+    -> Either (ParseError Int TBL.Builder) (a, B.ByteString)+runGetter p bs =+    case FP.runParser p bs of+      FP.OK   a bs' -> Right (a, bs')+      FP.Err  e     ->+        -- TODO check this is right. might need length of bs' ... ?+        Left $ fmap (mapParseErrorSinglePos (\(FP.Pos pos) -> len - pos)) e+      FP.Fail       -> Left []+  where len = B.length bs -    deriving stock (Eq, Show, Generic)+instance GenericTraverse Get where+    type GenericTraverseF Get = Getter+    type GenericTraverseC Get a = Get a+    genericTraverseAction dtName cstrName mFieldName fieldIdx =+        get `cutting1` e+      where+        e = parseErrorTextGenericFieldBld dtName cstrName mFieldName fieldIdx -eBase :: EBase -> Getter a-eBase = FP.err . EBase+getGenericNonSum+    :: forall a+    .  ( Generic a, GTraverseNonSum Get (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => Getter a+getGenericNonSum = genericTraverseNonSum @Get --- | TODO confirm correct operation (error combination)-getEWrap :: Get a => (E -> E) -> Getter a-getEWrap f = FP.cutting get (f $ EBase EFail) (\e _ -> f e)+instance+  ( Generic a, GTraverseNonSum Get (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => Get (GenericallyNonSum a) where+    get = GenericallyNonSum <$> getGenericNonSum -getEBase :: Get a => EBase -> Getter a-getEBase = FP.cut get . EBase+getGenericSum+    :: forall sumtag pt a+    .  ( Generic a, GTraverseSum Get sumtag (Rep a)+       , Get pt+       , GAssertNotVoid a, GAssertSum a+    ) => ParseCstrTo sumtag pt+      -> (pt -> pt -> Bool)+      -> Getter a+getGenericSum parseCstr ptEq =+    genericTraverseSum @Get @sumtag parseCstr ptGet fNoMatch ptEq+  where+      fNoMatch dtName = err1 (parseErrorTextGenericNoCstrMatchBld dtName)+      ptGet dtName = get `cutting1` parseErrorTextGenericSumTagBld dtName -cutEBase :: Getter a -> EBase -> Getter a-cutEBase f e = FP.cut f $ EBase e+getGenericSumRaw+    :: forall pt a+    .  ( Generic a, GTraverseSum Get Raw (Rep a)+       , Get pt+       , GAssertNotVoid a, GAssertSum a+    ) => (String -> pt)+      -> (pt -> pt -> Bool)+      -> Getter a+getGenericSumRaw parseCstr ptEq =+    genericTraverseSumRaw @Get parseCstr ptGet fNoMatch ptEq+  where+      fNoMatch dtName = err1 (parseErrorTextGenericNoCstrMatchBld dtName)+      ptGet dtName = get `cutting1` parseErrorTextGenericSumTagBld dtName -data EBase-  = ENoVoid-  | EFail+-- | Emit a single error. Use with flatparse primitives that only 'FP.Fail'.+err1 :: [text] -> FP.ParserT st (ParseError FP.Pos text) a+err1 = FP.err' . parseError1 -  | EExpectedByte Word8 Word8-  -- ^ expected first, got second+-- | Turn a 'FP.Fail' into a single error. (Re-emits existing 'FP.Error's.)+--+-- Use when wrapping flatparse primitives that directly only 'FP.Fail'. (It's+-- fine to use with combinators if the combinator itself doesn't 'FP.Error'.)+cut1+    :: FP.ParserT st (ParseError FP.Pos text) a -> [text]+    -> FP.ParserT st (ParseError FP.Pos text) a+cut1 p texts = p `FP.cut'` parseError1 texts -  | EOverlong BLenT BLenT-  -- ^ expected first, got second+-- | Turn a 'FP.Fail' into a single error, or prepend it to any existing ones.+--+-- Use when wrapping other 'get'ters.+--+-- We reimplement 'FP.cutting' with a tweak. Otherwise, we'd have to join lists+-- in the error case (instead of simply prepending).+cutting1+    :: FP.ParserT st (ParseError FP.Pos text) a -> [text]+    -> FP.ParserT st (ParseError FP.Pos text) a+cutting1 (FP.ParserT p) texts =+    FP.getPos >>= \pos -> FP.ParserT $ \fp eob s st ->+        case p fp eob s st of+          FP.Fail# st'    -> FP.Err# st' [ParseErrorSingle pos texts]+          FP.Err#  st' e' -> FP.Err# st' (ParseErrorSingle pos texts : e')+          x            -> x -  | EExpected B.ByteString B.ByteString-  -- ^ expected first, got second+-- We can't provide a Generically instance because the user must choose between+-- sum and non-sum handlers. -  | EFailNamed String-  -- ^ known fail+instance GenericFOnCstr Get where+    type GenericFOnCstrF Get = Getter+    type GenericFOnCstrC Get dtName cstrName gf =+        GTraverseC Get dtName cstrName 0 gf+    genericFOnCstrF (_ :: Proxy# '(dtName, cstrName)) =+        gTraverseC @Get @dtName @cstrName @0 -  | EFailParse String B.ByteString Word8-  -- ^ parse fail (where you parse a larger object, then a smaller one in it)+-- TODO this is hard to parse visually. document...?+fpToBz+    :: FP.ParserT st (ParseError FP.Pos text) a -> Int#+    -> (a -> Int# -> BZ.ParserT st (ParseError Int text) r)+    -> BZ.ParserT st (ParseError Int text) r+fpToBz (FP.ParserT p) len# fp = BZ.ParserT $ \fpc base# os# st0 ->+    case p fpc (base# `plusAddr#` (os# +# len#)) (base# `plusAddr#` os#) st0 of+      FP.OK#   st1 a s ->+        let unconsumed# = s `minusAddr#` (base# `plusAddr#` os#)+        in  BZ.runParserT# (fp a unconsumed#) fpc base# (os# +# unconsumed#) st1+      FP.Err#  st1 e   ->+        -- on error, we turn the flatparse 'FP.Pos' indices into actual byte+        -- offsets (which bytezap deals in), then emit+        let e' = fmap (mapParseErrorSinglePos (\(FP.Pos pos) -> I# len# - pos)) e+        in  BZ.Err# st1 e'+      FP.Fail# st1     -> BZ.Fail# st1 -  | ERanOut Natural-  -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0)+newtype ViaGetC a = ViaGetC { unViaGetC :: a }+instance (GetC a, KnownNat (CBLen a)) => Get (ViaGetC a) where+    {-# INLINE get #-}+    get = ViaGetC <$> bzToFp getC -    deriving stock (Eq, Show, Generic)+-- TODO messy ran out of input handling. should be a util for it+-- TODO pos handling seems correct on quick test. need stronger assertion plz+bzToFp :: forall a. KnownNat (CBLen a) => GetterC a -> Getter a+bzToFp (BZ.ParserT p) =+    (FP.ensure (I# len#) `cut1` eRanOut) >> FP.getPos >>= \(FP.Pos pos) ->+        FP.ParserT $ \fpc _eob s st0 ->+            case p fpc s 0# st0 of+              BZ.OK#   st1 a -> FP.OK#   st1 a (s `plusAddr#` len#)+              BZ.Err#  st1 e ->+                let e' = fmap (mapParseErrorSinglePos (\idx -> FP.Pos (pos - idx))) e+                in  FP.Err# st1 e'+              BZ.Fail# st1   -> FP.Fail# st1+  where+    !(I# len#) = cblen @a+    eRanOut = [ "ran out of input while running inner parser"+              , "bytes needed: "<>TBL.fromDec (I# len#) ] -data EGeneric-  = EGenericSum EGenericSum-  | EGenericField String (Maybe String) Natural E-    deriving stock (Eq, Show, Generic)+instance TypeError ENoEmpty => Get Void where get = undefined+instance TypeError ENoSum => Get (Either a b) where get = undefined -data EGenericSum-  = EGenericSumTag E-  | EGenericSumTagNoMatch [String] Text-    deriving stock (Eq, Show, Generic)+{- -class Get a where-    -- | Parse from binary.-    get :: Getter a+-- | 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 -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+-- | Unit type parses nothing.+instance Get () where+    {-# INLINE get #-}+    get = pure () --- | Impossible to parse 'Void'.-instance Get Void where-    get = eBase ENoVoid+-- | 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 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.+-- | Parse elements until EOF. Sometimes used at the "top" of binary formats. instance Get a => Get [a] where-    get = go+    -- TODO slow, uses reverse. build a DList instead+    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)+        go as = FP.branch FP.eof (pure (reverse as)) (get >>= \a -> go (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-    get = FP.takeRestBs+    {-# INLINE get #-}+    get = B.copy <$> FP.takeRest -instance Get Word8 where get = cutEBase FP.anyWord8 (ERanOut 1)-instance Get  Int8 where get = cutEBase FP.anyInt8  (ERanOut 1)+-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPrim Word8 instance Get Word8 +-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPrim  Int8 instance Get  Int8++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via Word8 instance Get (ByteOrdered end Word8)++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via  Int8 instance Get (ByteOrdered end  Int8)++-- | Parse any 'Prim''.+getPrim :: forall a. (Prim' a, Typeable a) => Getter a+getPrim = do+    lenAvail <- FP.remaining+    FP.anyPrim `cut1`+        [  "ran out of bytes while parsing " <> strTR+        <> ", needed "    <> strLenNeed+        <> ", remaining " <> TBL.fromDec lenAvail+        ]+  where+    strTR       = fromString (show (typeRep' @a))+    strLenNeed  = TBL.fromDec (sizeOf (undefined :: a))++typeRep' :: forall a. Typeable a => TypeRep+typeRep' = typeRep (Proxy @a)++instance (Prim' a, Typeable a) => Get (ViaPrim a) where+    get = ViaPrim <$> getPrim++-- ByteSwap is required on opposite endian platforms, but we're not checking+-- here, so make sure to keep it on both.+deriving via ViaPrim (ByteOrdered LittleEndian a)+    instance (Prim' a, ByteSwap a, Typeable a)+      => Get (ByteOrdered LittleEndian a)+deriving via ViaPrim (ByteOrdered    BigEndian a)+    instance (Prim' a, ByteSwap a, Typeable a)+      => Get (ByteOrdered    BigEndian a)++instance Get (Refined pr (Refined pl a)) => Get (Refined (pl `And` pr) a) where+    get = (unsafeRefine . unrefine @pl . unrefine @pr) <$> get++{-+ -- | A type that can be parsed from binary given some environment. -- -- Making this levity polymorphic makes things pretty strange, but is useful.@@ -143,3 +317,5 @@     :: GetWith (r :: TYPE LiftedRep) a     => r -> B.ByteString -> Either E (a, B.ByteString) runGetWith r bs = runGetter (getWith r) bs++-}
+ src/Binrep/Get/Error.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-} -- for easy error building++-- | Common parser error definitions.++module Binrep.Get.Error where++import Data.Text.Builder.Linear qualified as TBL+import Data.Text qualified as Text+import Numeric.Natural ( Natural )++-- | Top-level parse error.+--+-- The final element is the concrete error. Prior elements should "contain" the+-- error (i.e. be the larger part that the error occurred in).+--+-- Really should be non-empty-- but by using List, we can use the empty list for+-- Fail. Bit of a cute cheat.+type ParseError pos text = [ParseErrorSingle pos text]++-- | A single indexed parse error.+data ParseErrorSingle pos text = ParseErrorSingle+  { parseErrorSinglePos  :: pos+  , parseErrorSingleText :: [text]+  } deriving stock Show++-- | Map over the @pos@ index type of a 'ParseErrorSingle'.+mapParseErrorSinglePos+    :: (pos1 -> pos2)+    -> ParseErrorSingle pos1 text+    -> ParseErrorSingle pos2 text+mapParseErrorSinglePos f (ParseErrorSingle pos text) =+    ParseErrorSingle (f pos) text++-- | Shorthand for one parse error.+parseError1 :: [text] -> pos -> ParseError pos text+parseError1 texts pos = [ParseErrorSingle pos texts]++-- | Construct a parse error message for a generic field failure.+parseErrorTextGenericFieldBld+    :: String -> String -> Maybe String -> Natural+    -> [TBL.Builder]+parseErrorTextGenericFieldBld dtName cstrName (Just fieldName) _fieldIdx =+  [    "in " <> TBL.fromText (Text.pack dtName)+    <>   "." <> TBL.fromText (Text.pack cstrName)+    <>   "." <> TBL.fromText (Text.pack fieldName) ]+parseErrorTextGenericFieldBld dtName cstrName Nothing           fieldIdx =+  [    "in " <> TBL.fromText (Text.pack dtName)+    <>   "." <> TBL.fromText (Text.pack cstrName)+    <>   "." <> TBL.fromUnboundedDec fieldIdx ]++-- | Construct a parse error message for a generic sum tag no-match.+parseErrorTextGenericNoCstrMatchBld :: String -> [TBL.Builder]+parseErrorTextGenericNoCstrMatchBld dtName =+  [    "sum tag did not match any constructors in "+    <> TBL.fromText (Text.pack dtName) ]++-- | Construct a parse error message for a generic sum tag parse error.+parseErrorTextGenericSumTagBld :: String -> [TBL.Builder]+parseErrorTextGenericSumTagBld dtName =+  [    "while parsing sum tag in " <> TBL.fromText (Text.pack dtName) ]
+ src/Binrep/Get/Struct.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE UndecidableInstances #-} -- for Generically instance+{-# LANGUAGE OverloadedStrings #-} -- for easy error building++module Binrep.Get.Struct+  ( GetterC, GetC(getC)+  , getGenericStruct+  , runGetCBs+  , unsafeRunGetCPtr+  ) where++import Binrep.Get.Error+import Data.Text.Builder.Linear qualified as TBL+import Bytezap.Parser.Struct+import Bytezap.Parser.Struct.Generic+import Binrep.CBLen+import Foreign.Ptr ( Ptr )+import Data.Void ( Void )+import GHC.Exts ( Proxy#, Int(I#) )+import GHC.TypeNats ( KnownNat )+import GHC.Generics++import Binrep.Common.Via.Prim ( ViaPrim(..) )+import Raehik.Compat.Data.Primitive.Types ( Prim' )++import Data.Word ( Word8 )+import Data.Int ( Int8 )+import Binrep.Util.ByteOrder+import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )++import Data.ByteString qualified as B++import Generic.Type.Assert++import Binrep.Common.Via.Generically.NonSum++import Rerefined.Refine+import Rerefined.Predicate.Logical.And++type GetterC = Parser (ParseError Int TBL.Builder)++-- | constant size parser+class GetC a where getC :: GetterC a++-- | Consume 'Result'.+finishGetterC+    :: Result (ParseError Int TBL.Builder) a+    -> Either (ParseError Int TBL.Builder) a+finishGetterC = \case+  OK  a -> Right a+  Err e -> Left  e+  Fail  -> Left  []++runGetCBs+    :: forall a. (GetC a, KnownNat (CBLen a))+    => B.ByteString -> Either (ParseError Int TBL.Builder) a+runGetCBs bs =+    if   lenReq <= lenAvail+    then finishGetterC $ unsafeRunParserBs bs getC+    else Left [ParseErrorSingle 0 [errMsg]]+  where+    lenReq   = cblen @a+    lenAvail = B.length bs+    errMsg   =+        "input too short (need "<>TBL.fromDec lenReq+                      <>", got "<>TBL.fromDec lenAvail<>")"++-- | doesn't check len+unsafeRunGetCPtr+    :: forall a. GetC a+    => Ptr Word8 -> Either (ParseError Int TBL.Builder) a+unsafeRunGetCPtr ptr = finishGetterC $ unsafeRunParserPtr ptr getC++instance GParseBase GetC where+    type GParseBaseSt GetC = Proxy# Void+    type GParseBaseC  GetC a = GetC a+    type GParseBaseE  GetC = ParseError Int TBL.Builder+    gParseBase dtName cstrName mFieldName fieldIdx = getC `cutting1` e+      where+        e = parseErrorTextGenericFieldBld dtName cstrName mFieldName fieldIdx+    type GParseBaseLenTF GetC = CBLenSym++-- | Turn a 'Fail' into a single error, or prepend it to any existing ones.+--+-- Use when wrapping other 'get'ters.+--+-- We reimplement @cutting@ with a tweak. Otherwise, we'd have to join lists in+-- the error case (instead of simply prepending).+cutting1+    :: ParserT st (ParseError Int text) a -> [text]+    -> ParserT st (ParseError Int text) a+cutting1 (ParserT p) texts = ParserT $ \fpc base# os# st ->+    case p fpc base# os# st of+      Fail# st'    -> Err# st' [ParseErrorSingle (I# os#) texts]+      Err#  st' e' -> Err# st' (ParseErrorSingle (I# os#) texts : e')+      x               -> x++-- | Serialize a term of the struct-like type @a@ via its 'Generic' instance.+getGenericStruct+    :: forall a+    .  ( Generic a, GParse GetC (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => GetterC a+getGenericStruct = to <$> gParse @GetC++instance+  ( Generic a, GParse GetC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => GetC (Generically a) where+    getC = Generically <$> getGenericStruct++instance+  ( Generic a, GParse GetC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => GetC (GenericallyNonSum a) where+    getC = GenericallyNonSum <$> getGenericStruct++instance GetC (Refined pr (Refined pl a))+  => GetC (Refined (pl `And` pr) a) where+    getC = (unsafeRefine . unrefine @pl . unrefine @pr) <$> getC++instance GetC () where+    {-# INLINE getC #-}+    getC = constParse ()++instance Prim' a => GetC (ViaPrim a) where+    getC = ViaPrim <$> prim+    {-# INLINE getC #-}++deriving via ViaPrim Word8 instance GetC Word8+deriving via ViaPrim  Int8 instance GetC  Int8+deriving via Word8 instance GetC (ByteOrdered end Word8)+deriving via  Int8 instance GetC (ByteOrdered end  Int8)++-- ByteSwap is required on opposite endian platforms, but we're not checking+-- here, so make sure to keep it on both.+deriving via ViaPrim (ByteOrdered LittleEndian a)+    instance (Prim' a, ByteSwap a) => GetC (ByteOrdered LittleEndian a)+deriving via ViaPrim (ByteOrdered    BigEndian a)+    instance (Prim' a, ByteSwap a) => GetC (ByteOrdered    BigEndian a)
src/Binrep/Put.hs view
@@ -1,69 +1,136 @@+{-# LANGUAGE UndecidableInstances #-} -- for various stuff+{-# LANGUAGE AllowAmbiguousTypes #-} -- for type-level sum type handling+ module Binrep.Put where -import Mason.Builder qualified as Mason+import Binrep.BLen ( BLen(blen) )+import Binrep.CBLen ( IsCBLen(CBLen), cblen )+import Bytezap.Poke+import Raehik.Compat.Data.Primitive.Types ( Prim', sizeOf )+import Binrep.Util.ByteOrder+import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )+import Binrep.Common.Via.Prim ( ViaPrim(..) )  import Data.ByteString qualified as B +import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty )+import GHC.TypeLits ( TypeError, KnownNat )++import GHC.Generics+import Generic.Data.Function.FoldMap+import Generic.Data.MetaParse.Cstr ( Raw, ParseCstrTo )+import Generic.Type.Assert++import Control.Monad.ST ( RealWorld )++import Binrep.Put.Struct ( PutC(putC) )++import Rerefined.Refine+import Rerefined.Predicate.Logical.And+ import Data.Word import Data.Int-import Data.Void ( Void, absurd )+import Data.Void+import Binrep.Common.Via.Generically.NonSum -type Builder = Mason.BuilderFor Mason.StrictByteStringBackend+type Putter = Poke RealWorld+class Put a where put :: a -> Putter -class Put a where-    -- | Serialize to binary.-    put :: a -> Builder+runPut :: (BLen a, Put a) => a -> B.ByteString+runPut a = unsafeRunPokeBS (blen a) (put a) --- | Run the serializer.-runPut :: Put a => a -> B.ByteString-runPut = runBuilder . put+-- | Serialize generically using generic 'foldMap'.+instance GenericFoldMap Put where+    type GenericFoldMapM Put = Putter+    type GenericFoldMapC Put a = Put a+    genericFoldMapF = put -runBuilder :: Builder -> B.ByteString-runBuilder = Mason.toStrictByteString+-- | Serialize a term of the non-sum type @a@ via its 'Generic' instance.+putGenericNonSum+    :: forall a+    .  ( Generic a, GFoldMapNonSum Put (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => a -> Putter+putGenericNonSum = genericFoldMapNonSum @Put --- | Impossible to serialize 'Void'.-instance Put Void where-    put = absurd+instance+  ( Generic a, GFoldMapNonSum Put (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => Put (GenericallyNonSum a) where+    put = putGenericNonSum . unGenericallyNonSum --- | 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+-- | Serialize a term of the sum type @a@ via its 'Generic' instance.+putGenericSum+    :: forall sumtag a+    .  ( Generic a, GFoldMapSum Put sumtag (Rep a)+       , GAssertNotVoid a, GAssertSum a+    ) => ParseCstrTo sumtag Putter -> a -> Putter+putGenericSum = genericFoldMapSum @Put @sumtag -instance (Put a, Put b) => Put (a, b) where-    put (a, b) = put a <> put b+-- | Serialize a term of the sum type @a@ via its 'Generic' instance, without+--   pre-parsing constructor names.+putGenericSumRaw+    :: forall a+    .  ( Generic a, GFoldMapSum Put Raw (Rep a)+       , GAssertNotVoid a, GAssertSum a+    ) => (String -> Putter) -> a -> Putter+putGenericSumRaw = genericFoldMapSumRaw @Put --- | 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+newtype ViaPutC a = ViaPutC { unViaPutC :: a }+instance (PutC a, KnownNat (CBLen a)) => Put (ViaPutC a) where     {-# INLINE put #-}+    put = fromStructPoke (cblen @a) . putC . unViaPutC --- need to give args for RankNTypes reasons I don't understand-instance Put Word8 where-    put w = Mason.word8 w+-- use ViaPutC over this, but should be semantically identical+instance Prim' a => Put (ViaPrim a) where+    put = fromStructPoke (sizeOf (undefined :: a)) . putC     {-# INLINE put #-}-instance Put  Int8 where-    put w = Mason.int8 w++instance TypeError ENoEmpty => Put Void where put = undefined+instance TypeError ENoSum => Put (Either a b) where put = undefined++instance Put Putter where put = id++-- | Unit type serializes to nothing. How zen.+instance Put () where     {-# INLINE put #-}+    put = mempty --- | 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+instance (Put l, Put r) => Put (l, r) where+    {-# INLINE put #-}+    put (l, r) = put l <> put r --- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding).-putWithout :: Put a => a -> Either String Builder-putWithout = Right . put+instance Put a => Put [a] where+    {-# INLINE put #-}+    put = mconcat . map put -instance Put a => PutWith r [a]+instance Put B.ByteString where+    {-# INLINE put #-}+    put = byteString --- | 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+-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPutC Word8 instance Put Word8++-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPutC  Int8 instance Put  Int8++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via Word8 instance Put (ByteOrdered end Word8)++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via  Int8 instance Put (ByteOrdered end  Int8)++-- ByteSwap is required on opposite endian platforms, but we're not checking+-- here, so make sure to keep it on both.+-- Stick with ViaPrim here because ByteOrdered is connected to it.+deriving via ViaPrim (ByteOrdered LittleEndian a)+    instance (Prim' a, ByteSwap a) => Put (ByteOrdered LittleEndian a)+deriving via ViaPrim (ByteOrdered    BigEndian a)+    instance (Prim' a, ByteSwap a) => Put (ByteOrdered    BigEndian a)++-- | Put types refined with multiple predicates by wrapping the left+--   predicate with the right. LOL REALLY?+instance Put (Refined pr (Refined pl a)) => Put (Refined (pl `And` pr) a) where+    put = put . unsafeRefine @_ @pr . unsafeRefine @_ @pl . unrefine
+ src/Binrep/Put/Struct.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE UndecidableInstances #-} -- for @KnownNat (CBLen a)@ in head++module Binrep.Put.Struct where++import Bytezap.Struct qualified as Struct+import Bytezap.Struct.Generic qualified as Struct+import Control.Monad.ST ( RealWorld )+import Binrep.CBLen+import GHC.TypeLits ( KnownNat )+import GHC.Generics+import Data.ByteString qualified as B++import Binrep.Common.Via.Prim ( ViaPrim(..) )+import Raehik.Compat.Data.Primitive.Types ( Prim' )+import Data.Word+import Data.Int+import Binrep.Util.ByteOrder+import Raehik.Compat.Data.Primitive.Types.Endian ( ByteSwap )++import Binrep.Common.Class.TypeErrors ( ENoSum, ENoEmpty )+import GHC.TypeLits ( TypeError )+import Data.Void++import Generic.Type.Assert++import Binrep.Common.Via.Generically.NonSum++import Rerefined.Refine+import Rerefined.Predicate.Logical.And++type PutterC = Struct.Poke RealWorld++-- | constant size putter+class PutC a where putC :: a -> PutterC++runPutC :: forall a. (PutC a, KnownNat (CBLen a)) => a -> B.ByteString+runPutC = Struct.unsafeRunPokeBS (cblen @a) . putC++instance Struct.GPokeBase PutC where+    type GPokeBaseSt PutC   = RealWorld+    type GPokeBaseC  PutC a = PutC a+    gPokeBase = Struct.unPoke . putC+    type GPokeBaseLenTF PutC = CBLenSym++-- | Serialize a term of the struct-like type @a@ via its 'Generic' instance.+putGenericStruct+    :: forall a+    .  ( Generic a, Struct.GPoke PutC (Rep a)+       , GAssertNotVoid a, GAssertNotSum a+    ) => a -> PutterC+putGenericStruct = Struct.Poke . Struct.gPoke @PutC . from++instance+  ( Generic a, Struct.GPoke PutC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => PutC (Generically a) where+    putC (Generically a) = putGenericStruct a++instance+  ( Generic a, Struct.GPoke PutC (Rep a)+  , GAssertNotVoid a, GAssertNotSum a+  ) => PutC (GenericallyNonSum a) where+    putC = putGenericStruct . unGenericallyNonSum++instance PutC (Refined pr (Refined pl a))+  => PutC (Refined (pl `And` pr) a) where+    putC = putC . unsafeRefine @_ @pr . unsafeRefine @_ @pl . unrefine++instance Prim' a => PutC (ViaPrim a) where+    putC = Struct.prim . unViaPrim+    {-# INLINE putC #-}++instance TypeError ENoEmpty => PutC Void where putC = undefined+instance TypeError ENoSum => PutC (Either a b) where putC = undefined++instance PutC PutterC where putC = id++-- | Unit type serializes to nothing. How zen.+instance PutC () where+    {-# INLINE putC #-}+    putC () = Struct.emptyPoke++-- | Look weird? Yeah. But it's correct :)+instance (PutC l, KnownNat (CBLen l), PutC r) => PutC (l, r) where+    {-# INLINE putC #-}+    putC (l, r) = Struct.sequencePokes (putC l) (cblen @l) (putC r)++-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPrim Word8 instance PutC Word8++-- | 8-bit (1-byte) words do not require byte order in order to precisely+--   define their representation.+deriving via ViaPrim  Int8 instance PutC  Int8++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via Word8 instance PutC (ByteOrdered end Word8)++-- | Byte order is irrelevant for 8-bit (1-byte) words.+deriving via  Int8 instance PutC (ByteOrdered end  Int8)++-- ByteSwap is required on opposite endian platforms, but we're not checking+-- here, so make sure to keep it on both.+deriving via ViaPrim (ByteOrdered LittleEndian a)+    instance (Prim' a, ByteSwap a) => PutC (ByteOrdered LittleEndian a)+deriving via ViaPrim (ByteOrdered    BigEndian a)+    instance (Prim' a, ByteSwap a) => PutC (ByteOrdered    BigEndian a)
src/Binrep/Type/AsciiNat.hs view
@@ -1,105 +1,197 @@-{-| Naturals represented via ASCII numerals.+{-| Naturals represented via ASCII digits.  A concept which sees occasional use in places where neither speed nor size-efficiency matter.+efficiency matter. The tar file format uses it, apparently to sidestep making a+decision on byte ordering. Pretty silly. -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.+As with other binrep string-likes, you probably want to wrap this with+'Binrep.Type.Sized.Sized' or 'Binrep.Type.Prefix.Size.SizePrefixed'. -I don't really see the usage of these. It seems silly and inefficient, aimed-solely at easing debugging.+We use a refinement to permit using any numeric type, while ensuring that+negative values are not permitted. -}  {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-} -- for refined error+{-# LANGUAGE UndecidableInstances #-} -- for deriving predicate instance  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 GHC.Exts ( Word(W#), Word#, Int(I#), word2Int#, eqWord#, plusWord# )+import Util.TypeNats ( natValWord ) import Data.Semigroup ( sconcat ) +import GHC.Num.Primitives ( wordLogBase# )+import GHC.Num.Natural ( naturalSizeInBase# )++import Data.Word+import Data.Int+import Data.List.NonEmpty ( NonEmpty( (:|) ) )+ import GHC.TypeNats ( Natural, KnownNat )-import GHC.Num.Natural ( naturalSizeInBase#, naturalToWord# ) -import GHC.Generics ( Generic )-import Data.Data ( Data )-import Numeric ( showOct, showHex, showBin, showInt )+import Data.ByteString qualified as B+import Binrep.Type.Thin ( Thin(Thin) ) --- | A 'Natural' represented in binary as an ASCII string, where each character---   a is a digit in the given base (> 1).+import Rerefined.Predicate+import Rerefined.Predicate.Via+import Rerefined.Predicate.Relational.Value+import Rerefined.Predicate.Relational+import Rerefined.Refine+import TypeLevelShow.Natural+import TypeLevelShow.Utils++import Data.Text.Builder.Linear qualified as TBL++{- TODO 2024-10-15 raehik++Should this be a newtype over @a@ where we don't check for >0 ?+After doing some thinking about strongweak vs. generic coerce, I kind of want to+handle cases where we don't really do a check/make a value-level change.+This is the closest I have.++Maybe I want a @Tagged@-like newtype in strongweak that states "strengthen+through the given type as if it's a newtype (that can be coerced)". Maybe that+gets me what I want. @ByteOrdered@ would then use it too.+-}++-- | A natural represented in binary as an ASCII string, where each character is+--   a digit in the given base. ----- '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+-- Only certain bases are supported: 2, 8, 10 and 16.+--+-- Hex parsing permits mixed case digits when parsing (@1-9a-fA-F@), and+-- serializes with lower-case ASCII hex digits.+data AsciiNat (base :: Natural)+--type AsciiNat base = Refined (AsciiNat base) -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)+instance Predicate (AsciiNat base) where+    type PredicateName d (AsciiNat base) = ShowParen (d > 9)+        ("AsciiNat " ++ ShowNatDec base) --- | Compare two 'AsciiNat's with arbitrary bases.-asciiNatCompare :: AsciiNat b1 -> AsciiNat b2 -> Ordering-asciiNatCompare (AsciiNat n1) (AsciiNat n2) = compare n1 n2+instance (KnownPredicateName (AsciiNat base), Num a, Ord a)+  => Refine (AsciiNat base) a where+    validate = validateVia @(CompareValue RelOpGTE Pos 0) +-- | Compare two 'AsciiNat's, ignoring base information.+asciiNatCompare+    :: Ord a => Refined (AsciiNat bl) a -> Refined (AsciiNat br) a -> Ordering+asciiNatCompare l r = compare (unrefine l) (unrefine r)+ -- | 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+--   the given base. We can calculate this generally with great efficiency+--   using GHC (ghc-bignum) primitives!+instance (HasBaseOps a, KnownNat base) => BLen (Refined (AsciiNat base) a) where+    blen n = I# (word2Int# (sizeInBase# base# (unrefine n)))+      where+        !(W# base#) = natValWord @base ---------------------------------------------------------------------------------+class HasBaseOps a where+    -- | See ghc-bignum internals at @GHC.Num.*@.+    sizeInBase# :: Word# -> a -> Word# -instance Put (AsciiNat 8) where-    put = natToAsciiBytes (+ 0x30) 8 . getAsciiNat+instance HasBaseOps Word    where sizeInBase# = sizeInBaseWordSize+instance HasBaseOps Natural where+    sizeInBase# base = \case+      0 -> 1##+      a -> naturalSizeInBase# base a -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+instance HasBaseOps Word8  where sizeInBase# = sizeInBaseWordSize+instance HasBaseOps Word16 where sizeInBase# = sizeInBaseWordSize+instance HasBaseOps Word32 where sizeInBase# = sizeInBaseWordSize -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+-- | TODO unsafe for 32-bit platform+instance HasBaseOps Word64 where sizeInBase# = sizeInBaseWordSize ---------------------------------------------------------------------------------+instance HasBaseOps Int8   where sizeInBase# = sizeInBaseWordSize+instance HasBaseOps Int16  where sizeInBase# = sizeInBaseWordSize+instance HasBaseOps Int32  where sizeInBase# = sizeInBaseWordSize -natToAsciiBytes :: (Word8 -> Word8) -> Natural -> Natural -> Builder-natToAsciiBytes f base =-    sconcat . fmap (\w -> Mason.word8 w) . fmap f . digits @Word8 base+-- | TODO unsafe for 32-bit platform+instance HasBaseOps Int64  where sizeInBase# = sizeInBaseWordSize -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+-- | 'Int' can use 'Word' size (but TODO what happens for negatives?)+instance HasBaseOps Int  where sizeInBase# = sizeInBaseWordSize++-- | Safe for types smaller than a 'Word'.+--+-- Uses ghc-bignum internals. Slightly unwrapped for better performance.+--+-- One could perhaps write faster algorithms for smaller primitive types too...+-- but performance increase would be minimal if even present.+sizeInBaseWordSize :: Integral a => Word# -> a -> Word#+sizeInBaseWordSize base a =+    case w# `eqWord#` 0## of+      1# -> 1##+      _  -> 1## `plusWord#` wordLogBase# base w#   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)+    !(W# w#) = fromIntegral a -digits :: forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b-digits base = go []+-- | Serialize any term of an 'Integral' type to binary (base 2) ASCII.+instance Integral a => Put (Refined (AsciiNat  2) a) where+    put = sconcat . fmap (put . (+) 0x30) . unsafeDigits @Word8  2 . unrefine++-- | Serialize any term of an 'Integral' type to octal (base 8) ASCII.+instance Integral a => Put (Refined (AsciiNat  8) a) where+    put = sconcat . fmap (put . (+) 0x30) . unsafeDigits @Word8  8 . unrefine++-- | Serialize any term of an 'Integral' type to decimal (base 10) ASCII.+instance Integral a => Put (Refined (AsciiNat 10) a) where+    put = sconcat . fmap (put . (+) 0x30) . unsafeDigits @Word8 10 . unrefine++-- | Serialize any term of an 'Integral' type to hex (base 16) ASCII.+--+-- Uses lower-case ASCII.+instance Integral a => Put (Refined (AsciiNat 16) a) where+    put =+          sconcat . fmap (put . unsafeHexDigitToAsciiLower)+        . unsafeDigits @Word8 16 . unrefine++-- | Parse a  binary  (base 2) ASCII natural to any 'Num' type.+instance (Num a, Ord a) => Get (Refined (AsciiNat  2)  a) where+    get = unsafeRefine <$> getAsciiNatByByte 2  "binary"  parseBinaryAsciiDigit++-- | Parse an octal   (base 8) ASCII natural to any 'Num' type.+instance (Num a, Ord a) => Get (Refined (AsciiNat  8)  a) where+    get = unsafeRefine <$> getAsciiNatByByte 8  "octal"   parseOctalAsciiDigit++-- | Parse a  decimal (base 10) ASCII natural to any 'Num' type.+instance (Num a, Ord a) => Get (Refined (AsciiNat 10) a) where+    get = unsafeRefine <$> getAsciiNatByByte 10 "decimal" parseDecimalAsciiDigit++-- | Parse a  hex     (base 16) ASCII natural to any 'Num' type.+--+-- Parses lower and upper case (mixed permitted).+instance (Num a, Ord a) => Get (Refined (AsciiNat 16) a) where+    get = unsafeRefine <$> getAsciiNatByByte 16 "hex"     parseHexAsciiDigit++-- | Parse an ASCII natural in the given base with the given digit parser.+--+-- Parses byte-by-byte. As such, it only supports bases up to 256.+getAsciiNatByByte :: Num a => a -> TBL.Builder -> (a -> Maybe a) -> Getter a+getAsciiNatByByte base baseStr f = do+    Thin bs <- get -- no need to copy since we consume during parsing!+    if   B.null bs+    then err1 ["ASCII natural cannot be empty"]+    else case asciiBytesToNat f base bs of+          Left  b -> err1 [+            "non-"<>baseStr<>" ASCII digit in "+            <>baseStr<>" ASCII natural: "<>TBL.fromDec b]+          Right n -> pure n++{- | Get the digits in the given number as rendered in the given base.++Digits will be between 0-base. The return type must be sized to support this.++Base must be > 2. This is not checked. (Internal function eh.)++Note the 'NonEmpty' return type. Returns @[0]@ for 0 input. (This does not match+ghc-bignum's @sizeInBase@ primitives!)+-}+unsafeDigits :: forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b+unsafeDigits base = go []   where     go s x = loop (head' :| s) tail'       where@@ -108,3 +200,70 @@     loop s@(r :| rs) = \case         0 -> s         x -> go (r : rs) x++asciiBytesToNat+    :: Num a => (a -> Maybe a) -> a -> B.ByteString -> Either Word8 a+asciiBytesToNat f base bs =+    -- we use Int for exponent because it seems most sensible & gets SPECIALISEd+    case B.foldr go (Right (0, (0 :: Int))) bs of+      Left w -> Left w+      Right (n, _) -> Right n+  where+    go _ (Left w) = Left w+    go w (Right (n, expo)) =+        case f (fromIntegral w) of+          Nothing -> Left w+          Just d  -> Right (n + d * base^expo, expo+1)++parseBinaryAsciiDigit :: (Num a, Ord a) => a -> Maybe a+parseBinaryAsciiDigit = \case+  0x30 -> Just 0 -- 0+  0x31 -> Just 1 -- 1+  _    -> Nothing++parseOctalAsciiDigit :: (Num a, Ord a) => a -> Maybe a+parseOctalAsciiDigit a+  | a >= 0x30 && a <= 0x37 = Just $ a - 0x30 -- 0-7+  | otherwise = Nothing++parseDecimalAsciiDigit :: (Num a, Ord a) => a -> Maybe a+parseDecimalAsciiDigit a+  | a >= 0x30 && a <= 0x39 = Just $ a - 0x30 -- 0-9+  | otherwise = Nothing++parseHexAsciiDigit :: (Num a, Ord a) => a -> Maybe a+parseHexAsciiDigit a+  | a >= 0x30 && a <= 0x39 = Just $ a - 0x30 -- 0-9+  | a >= 0x41 && a <= 0x46 = Just $ a - 0x37 -- A-F (upper case)+  | a >= 0x61 && a <= 0x66 = Just $ a - 0x57 -- a-f (lower case)+  | otherwise = Nothing++-- | May only be called with 0<=n<=15.+unsafeHexDigitToAsciiLower :: (Num a, Ord a) => a -> a+unsafeHexDigitToAsciiLower a+  | a <= 9    = 0x30 + a+  | otherwise = 0x57 + a++{-++-- | Print a binary (base 2) ASCII natural with an @0b@ prefix.+prettyAsciiNat2 :: Integral a => Int -> a -> ShowS+prettyAsciiNat2 _ n = showString "0b" . showBin n++-- | Show binary (base 2) ASCII naturals with an @0b@ prefix.+instance Integral a => Show (AsciiNat 2 a) where+    showsPrec _ n = showString "0b" . showBin (unAsciiNat n)++-- | Show octal (base 8) ASCII naturals with an @0o@ prefix.+instance Integral a => Show (AsciiNat 8  a) where+    showsPrec _ n = showString "0o" . showOct (unAsciiNat n)++-- | Show decimal (base 10) ASCII naturals with no prefix.+instance Integral a => Show (AsciiNat 10 a) where+    showsPrec _ = showInt . unAsciiNat++-- | Show hex (base 16) ASCII naturals with an @0x@ prefix.+instance Integral a => Show (AsciiNat 16 a) where+    showsPrec _ n = showString "0x" . showHex (unAsciiNat n)++-}
− src/Binrep/Type/Byte.hs 
@@ -1,825 +0,0 @@-{- | Safe, if silly, byte representation for use at the type level.--'Word8' is a special type that GHC doesn't (and I think can't) promote to the-type level. We only have 'Natural's, which are unbounded. So we define a safe,-promotable representation, to allow us to prove well-sizedness at compile time.-Then we provide a bunch of type families and reifying typeclasses to enable-going between "similar" kinds ('Natural') and types ('Word8', 'B.ByteString')-respectively.--Type-level functionality is stored in 'Binrep.Type.Byte.TypeLevel' because the-definitions are even sillier than the ones here.--Do not use this on the term level. That would be _extremely_ silly.--}--{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}--module Binrep.Type.Byte where--import Mason.Builder qualified as Mason-import Data.ByteString.Builder.Prim.Internal qualified as BI-import Binrep.Util ( natVal'' )-import Binrep.Put ( Builder )-import GHC.TypeNats-import GHC.Exts---- Needs to be a function type to work. Interesting. It's perhaps not an--- improvement on regular boxed. But interesting idea, so sticking with it.-class ByteVal (n :: Natural) where byteVal :: Proxy# n -> Word8#--instance ByteVal 0x00 where-    byteVal _ = wordToWord8# 0x00##-    {-# INLINE byteVal #-}-instance ByteVal 0x01 where-    byteVal _ = wordToWord8# 0x01##-    {-# INLINE byteVal #-}-instance ByteVal 0x02 where-    byteVal _ = wordToWord8# 0x02##-    {-# INLINE byteVal #-}-instance ByteVal 0x03 where-    byteVal _ = wordToWord8# 0x03##-    {-# INLINE byteVal #-}-instance ByteVal 0x04 where-    byteVal _ = wordToWord8# 0x04##-    {-# INLINE byteVal #-}-instance ByteVal 0x05 where-    byteVal _ = wordToWord8# 0x05##-    {-# INLINE byteVal #-}-instance ByteVal 0x06 where-    byteVal _ = wordToWord8# 0x06##-    {-# INLINE byteVal #-}-instance ByteVal 0x07 where-    byteVal _ = wordToWord8# 0x07##-    {-# INLINE byteVal #-}-instance ByteVal 0x08 where-    byteVal _ = wordToWord8# 0x08##-    {-# INLINE byteVal #-}-instance ByteVal 0x09 where-    byteVal _ = wordToWord8# 0x09##-    {-# INLINE byteVal #-}-instance ByteVal 0x0a where-    byteVal _ = wordToWord8# 0x0a##-    {-# INLINE byteVal #-}-instance ByteVal 0x0b where-    byteVal _ = wordToWord8# 0x0b##-    {-# INLINE byteVal #-}-instance ByteVal 0x0c where-    byteVal _ = wordToWord8# 0x0c##-    {-# INLINE byteVal #-}-instance ByteVal 0x0d where-    byteVal _ = wordToWord8# 0x0d##-    {-# INLINE byteVal #-}-instance ByteVal 0x0e where-    byteVal _ = wordToWord8# 0x0e##-    {-# INLINE byteVal #-}-instance ByteVal 0x0f where-    byteVal _ = wordToWord8# 0x0f##-    {-# INLINE byteVal #-}-instance ByteVal 0x10 where-    byteVal _ = wordToWord8# 0x10##-    {-# INLINE byteVal #-}-instance ByteVal 0x11 where-    byteVal _ = wordToWord8# 0x11##-    {-# INLINE byteVal #-}-instance ByteVal 0x12 where-    byteVal _ = wordToWord8# 0x12##-    {-# INLINE byteVal #-}-instance ByteVal 0x13 where-    byteVal _ = wordToWord8# 0x13##-    {-# INLINE byteVal #-}-instance ByteVal 0x14 where-    byteVal _ = wordToWord8# 0x14##-    {-# INLINE byteVal #-}-instance ByteVal 0x15 where-    byteVal _ = wordToWord8# 0x15##-    {-# INLINE byteVal #-}-instance ByteVal 0x16 where-    byteVal _ = wordToWord8# 0x16##-    {-# INLINE byteVal #-}-instance ByteVal 0x17 where-    byteVal _ = wordToWord8# 0x17##-    {-# INLINE byteVal #-}-instance ByteVal 0x18 where-    byteVal _ = wordToWord8# 0x18##-    {-# INLINE byteVal #-}-instance ByteVal 0x19 where-    byteVal _ = wordToWord8# 0x19##-    {-# INLINE byteVal #-}-instance ByteVal 0x1a where-    byteVal _ = wordToWord8# 0x1a##-    {-# INLINE byteVal #-}-instance ByteVal 0x1b where-    byteVal _ = wordToWord8# 0x1b##-    {-# INLINE byteVal #-}-instance ByteVal 0x1c where-    byteVal _ = wordToWord8# 0x1c##-    {-# INLINE byteVal #-}-instance ByteVal 0x1d where-    byteVal _ = wordToWord8# 0x1d##-    {-# INLINE byteVal #-}-instance ByteVal 0x1e where-    byteVal _ = wordToWord8# 0x1e##-    {-# INLINE byteVal #-}-instance ByteVal 0x1f where-    byteVal _ = wordToWord8# 0x1f##-    {-# INLINE byteVal #-}-instance ByteVal 0x20 where-    byteVal _ = wordToWord8# 0x20##-    {-# INLINE byteVal #-}-instance ByteVal 0x21 where-    byteVal _ = wordToWord8# 0x21##-    {-# INLINE byteVal #-}-instance ByteVal 0x22 where-    byteVal _ = wordToWord8# 0x22##-    {-# INLINE byteVal #-}-instance ByteVal 0x23 where-    byteVal _ = wordToWord8# 0x23##-    {-# INLINE byteVal #-}-instance ByteVal 0x24 where-    byteVal _ = wordToWord8# 0x24##-    {-# INLINE byteVal #-}-instance ByteVal 0x25 where-    byteVal _ = wordToWord8# 0x25##-    {-# INLINE byteVal #-}-instance ByteVal 0x26 where-    byteVal _ = wordToWord8# 0x26##-    {-# INLINE byteVal #-}-instance ByteVal 0x27 where-    byteVal _ = wordToWord8# 0x27##-    {-# INLINE byteVal #-}-instance ByteVal 0x28 where-    byteVal _ = wordToWord8# 0x28##-    {-# INLINE byteVal #-}-instance ByteVal 0x29 where-    byteVal _ = wordToWord8# 0x29##-    {-# INLINE byteVal #-}-instance ByteVal 0x2a where-    byteVal _ = wordToWord8# 0x2a##-    {-# INLINE byteVal #-}-instance ByteVal 0x2b where-    byteVal _ = wordToWord8# 0x2b##-    {-# INLINE byteVal #-}-instance ByteVal 0x2c where-    byteVal _ = wordToWord8# 0x2c##-    {-# INLINE byteVal #-}-instance ByteVal 0x2d where-    byteVal _ = wordToWord8# 0x2d##-    {-# INLINE byteVal #-}-instance ByteVal 0x2e where-    byteVal _ = wordToWord8# 0x2e##-    {-# INLINE byteVal #-}-instance ByteVal 0x2f where-    byteVal _ = wordToWord8# 0x2f##-    {-# INLINE byteVal #-}-instance ByteVal 0x30 where-    byteVal _ = wordToWord8# 0x30##-    {-# INLINE byteVal #-}-instance ByteVal 0x31 where-    byteVal _ = wordToWord8# 0x31##-    {-# INLINE byteVal #-}-instance ByteVal 0x32 where-    byteVal _ = wordToWord8# 0x32##-    {-# INLINE byteVal #-}-instance ByteVal 0x33 where-    byteVal _ = wordToWord8# 0x33##-    {-# INLINE byteVal #-}-instance ByteVal 0x34 where-    byteVal _ = wordToWord8# 0x34##-    {-# INLINE byteVal #-}-instance ByteVal 0x35 where-    byteVal _ = wordToWord8# 0x35##-    {-# INLINE byteVal #-}-instance ByteVal 0x36 where-    byteVal _ = wordToWord8# 0x36##-    {-# INLINE byteVal #-}-instance ByteVal 0x37 where-    byteVal _ = wordToWord8# 0x37##-    {-# INLINE byteVal #-}-instance ByteVal 0x38 where-    byteVal _ = wordToWord8# 0x38##-    {-# INLINE byteVal #-}-instance ByteVal 0x39 where-    byteVal _ = wordToWord8# 0x39##-    {-# INLINE byteVal #-}-instance ByteVal 0x3a where-    byteVal _ = wordToWord8# 0x3a##-    {-# INLINE byteVal #-}-instance ByteVal 0x3b where-    byteVal _ = wordToWord8# 0x3b##-    {-# INLINE byteVal #-}-instance ByteVal 0x3c where-    byteVal _ = wordToWord8# 0x3c##-    {-# INLINE byteVal #-}-instance ByteVal 0x3d where-    byteVal _ = wordToWord8# 0x3d##-    {-# INLINE byteVal #-}-instance ByteVal 0x3e where-    byteVal _ = wordToWord8# 0x3e##-    {-# INLINE byteVal #-}-instance ByteVal 0x3f where-    byteVal _ = wordToWord8# 0x3f##-    {-# INLINE byteVal #-}-instance ByteVal 0x40 where-    byteVal _ = wordToWord8# 0x40##-    {-# INLINE byteVal #-}-instance ByteVal 0x41 where-    byteVal _ = wordToWord8# 0x41##-    {-# INLINE byteVal #-}-instance ByteVal 0x42 where-    byteVal _ = wordToWord8# 0x42##-    {-# INLINE byteVal #-}-instance ByteVal 0x43 where-    byteVal _ = wordToWord8# 0x43##-    {-# INLINE byteVal #-}-instance ByteVal 0x44 where-    byteVal _ = wordToWord8# 0x44##-    {-# INLINE byteVal #-}-instance ByteVal 0x45 where-    byteVal _ = wordToWord8# 0x45##-    {-# INLINE byteVal #-}-instance ByteVal 0x46 where-    byteVal _ = wordToWord8# 0x46##-    {-# INLINE byteVal #-}-instance ByteVal 0x47 where-    byteVal _ = wordToWord8# 0x47##-    {-# INLINE byteVal #-}-instance ByteVal 0x48 where-    byteVal _ = wordToWord8# 0x48##-    {-# INLINE byteVal #-}-instance ByteVal 0x49 where-    byteVal _ = wordToWord8# 0x49##-    {-# INLINE byteVal #-}-instance ByteVal 0x4a where-    byteVal _ = wordToWord8# 0x4a##-    {-# INLINE byteVal #-}-instance ByteVal 0x4b where-    byteVal _ = wordToWord8# 0x4b##-    {-# INLINE byteVal #-}-instance ByteVal 0x4c where-    byteVal _ = wordToWord8# 0x4c##-    {-# INLINE byteVal #-}-instance ByteVal 0x4d where-    byteVal _ = wordToWord8# 0x4d##-    {-# INLINE byteVal #-}-instance ByteVal 0x4e where-    byteVal _ = wordToWord8# 0x4e##-    {-# INLINE byteVal #-}-instance ByteVal 0x4f where-    byteVal _ = wordToWord8# 0x4f##-    {-# INLINE byteVal #-}-instance ByteVal 0x50 where-    byteVal _ = wordToWord8# 0x50##-    {-# INLINE byteVal #-}-instance ByteVal 0x51 where-    byteVal _ = wordToWord8# 0x51##-    {-# INLINE byteVal #-}-instance ByteVal 0x52 where-    byteVal _ = wordToWord8# 0x52##-    {-# INLINE byteVal #-}-instance ByteVal 0x53 where-    byteVal _ = wordToWord8# 0x53##-    {-# INLINE byteVal #-}-instance ByteVal 0x54 where-    byteVal _ = wordToWord8# 0x54##-    {-# INLINE byteVal #-}-instance ByteVal 0x55 where-    byteVal _ = wordToWord8# 0x55##-    {-# INLINE byteVal #-}-instance ByteVal 0x56 where-    byteVal _ = wordToWord8# 0x56##-    {-# INLINE byteVal #-}-instance ByteVal 0x57 where-    byteVal _ = wordToWord8# 0x57##-    {-# INLINE byteVal #-}-instance ByteVal 0x58 where-    byteVal _ = wordToWord8# 0x58##-    {-# INLINE byteVal #-}-instance ByteVal 0x59 where-    byteVal _ = wordToWord8# 0x59##-    {-# INLINE byteVal #-}-instance ByteVal 0x5a where-    byteVal _ = wordToWord8# 0x5a##-    {-# INLINE byteVal #-}-instance ByteVal 0x5b where-    byteVal _ = wordToWord8# 0x5b##-    {-# INLINE byteVal #-}-instance ByteVal 0x5c where-    byteVal _ = wordToWord8# 0x5c##-    {-# INLINE byteVal #-}-instance ByteVal 0x5d where-    byteVal _ = wordToWord8# 0x5d##-    {-# INLINE byteVal #-}-instance ByteVal 0x5e where-    byteVal _ = wordToWord8# 0x5e##-    {-# INLINE byteVal #-}-instance ByteVal 0x5f where-    byteVal _ = wordToWord8# 0x5f##-    {-# INLINE byteVal #-}-instance ByteVal 0x60 where-    byteVal _ = wordToWord8# 0x60##-    {-# INLINE byteVal #-}-instance ByteVal 0x61 where-    byteVal _ = wordToWord8# 0x61##-    {-# INLINE byteVal #-}-instance ByteVal 0x62 where-    byteVal _ = wordToWord8# 0x62##-    {-# INLINE byteVal #-}-instance ByteVal 0x63 where-    byteVal _ = wordToWord8# 0x63##-    {-# INLINE byteVal #-}-instance ByteVal 0x64 where-    byteVal _ = wordToWord8# 0x64##-    {-# INLINE byteVal #-}-instance ByteVal 0x65 where-    byteVal _ = wordToWord8# 0x65##-    {-# INLINE byteVal #-}-instance ByteVal 0x66 where-    byteVal _ = wordToWord8# 0x66##-    {-# INLINE byteVal #-}-instance ByteVal 0x67 where-    byteVal _ = wordToWord8# 0x67##-    {-# INLINE byteVal #-}-instance ByteVal 0x68 where-    byteVal _ = wordToWord8# 0x68##-    {-# INLINE byteVal #-}-instance ByteVal 0x69 where-    byteVal _ = wordToWord8# 0x69##-    {-# INLINE byteVal #-}-instance ByteVal 0x6a where-    byteVal _ = wordToWord8# 0x6a##-    {-# INLINE byteVal #-}-instance ByteVal 0x6b where-    byteVal _ = wordToWord8# 0x6b##-    {-# INLINE byteVal #-}-instance ByteVal 0x6c where-    byteVal _ = wordToWord8# 0x6c##-    {-# INLINE byteVal #-}-instance ByteVal 0x6d where-    byteVal _ = wordToWord8# 0x6d##-    {-# INLINE byteVal #-}-instance ByteVal 0x6e where-    byteVal _ = wordToWord8# 0x6e##-    {-# INLINE byteVal #-}-instance ByteVal 0x6f where-    byteVal _ = wordToWord8# 0x6f##-    {-# INLINE byteVal #-}-instance ByteVal 0x70 where-    byteVal _ = wordToWord8# 0x70##-    {-# INLINE byteVal #-}-instance ByteVal 0x71 where-    byteVal _ = wordToWord8# 0x71##-    {-# INLINE byteVal #-}-instance ByteVal 0x72 where-    byteVal _ = wordToWord8# 0x72##-    {-# INLINE byteVal #-}-instance ByteVal 0x73 where-    byteVal _ = wordToWord8# 0x73##-    {-# INLINE byteVal #-}-instance ByteVal 0x74 where-    byteVal _ = wordToWord8# 0x74##-    {-# INLINE byteVal #-}-instance ByteVal 0x75 where-    byteVal _ = wordToWord8# 0x75##-    {-# INLINE byteVal #-}-instance ByteVal 0x76 where-    byteVal _ = wordToWord8# 0x76##-    {-# INLINE byteVal #-}-instance ByteVal 0x77 where-    byteVal _ = wordToWord8# 0x77##-    {-# INLINE byteVal #-}-instance ByteVal 0x78 where-    byteVal _ = wordToWord8# 0x78##-    {-# INLINE byteVal #-}-instance ByteVal 0x79 where-    byteVal _ = wordToWord8# 0x79##-    {-# INLINE byteVal #-}-instance ByteVal 0x7a where-    byteVal _ = wordToWord8# 0x7a##-    {-# INLINE byteVal #-}-instance ByteVal 0x7b where-    byteVal _ = wordToWord8# 0x7b##-    {-# INLINE byteVal #-}-instance ByteVal 0x7c where-    byteVal _ = wordToWord8# 0x7c##-    {-# INLINE byteVal #-}-instance ByteVal 0x7d where-    byteVal _ = wordToWord8# 0x7d##-    {-# INLINE byteVal #-}-instance ByteVal 0x7e where-    byteVal _ = wordToWord8# 0x7e##-    {-# INLINE byteVal #-}-instance ByteVal 0x7f where-    byteVal _ = wordToWord8# 0x7f##-    {-# INLINE byteVal #-}-instance ByteVal 0x80 where-    byteVal _ = wordToWord8# 0x80##-    {-# INLINE byteVal #-}-instance ByteVal 0x81 where-    byteVal _ = wordToWord8# 0x81##-    {-# INLINE byteVal #-}-instance ByteVal 0x82 where-    byteVal _ = wordToWord8# 0x82##-    {-# INLINE byteVal #-}-instance ByteVal 0x83 where-    byteVal _ = wordToWord8# 0x83##-    {-# INLINE byteVal #-}-instance ByteVal 0x84 where-    byteVal _ = wordToWord8# 0x84##-    {-# INLINE byteVal #-}-instance ByteVal 0x85 where-    byteVal _ = wordToWord8# 0x85##-    {-# INLINE byteVal #-}-instance ByteVal 0x86 where-    byteVal _ = wordToWord8# 0x86##-    {-# INLINE byteVal #-}-instance ByteVal 0x87 where-    byteVal _ = wordToWord8# 0x87##-    {-# INLINE byteVal #-}-instance ByteVal 0x88 where-    byteVal _ = wordToWord8# 0x88##-    {-# INLINE byteVal #-}-instance ByteVal 0x89 where-    byteVal _ = wordToWord8# 0x89##-    {-# INLINE byteVal #-}-instance ByteVal 0x8a where-    byteVal _ = wordToWord8# 0x8a##-    {-# INLINE byteVal #-}-instance ByteVal 0x8b where-    byteVal _ = wordToWord8# 0x8b##-    {-# INLINE byteVal #-}-instance ByteVal 0x8c where-    byteVal _ = wordToWord8# 0x8c##-    {-# INLINE byteVal #-}-instance ByteVal 0x8d where-    byteVal _ = wordToWord8# 0x8d##-    {-# INLINE byteVal #-}-instance ByteVal 0x8e where-    byteVal _ = wordToWord8# 0x8e##-    {-# INLINE byteVal #-}-instance ByteVal 0x8f where-    byteVal _ = wordToWord8# 0x8f##-    {-# INLINE byteVal #-}-instance ByteVal 0x90 where-    byteVal _ = wordToWord8# 0x90##-    {-# INLINE byteVal #-}-instance ByteVal 0x91 where-    byteVal _ = wordToWord8# 0x91##-    {-# INLINE byteVal #-}-instance ByteVal 0x92 where-    byteVal _ = wordToWord8# 0x92##-    {-# INLINE byteVal #-}-instance ByteVal 0x93 where-    byteVal _ = wordToWord8# 0x93##-    {-# INLINE byteVal #-}-instance ByteVal 0x94 where-    byteVal _ = wordToWord8# 0x94##-    {-# INLINE byteVal #-}-instance ByteVal 0x95 where-    byteVal _ = wordToWord8# 0x95##-    {-# INLINE byteVal #-}-instance ByteVal 0x96 where-    byteVal _ = wordToWord8# 0x96##-    {-# INLINE byteVal #-}-instance ByteVal 0x97 where-    byteVal _ = wordToWord8# 0x97##-    {-# INLINE byteVal #-}-instance ByteVal 0x98 where-    byteVal _ = wordToWord8# 0x98##-    {-# INLINE byteVal #-}-instance ByteVal 0x99 where-    byteVal _ = wordToWord8# 0x99##-    {-# INLINE byteVal #-}-instance ByteVal 0x9a where-    byteVal _ = wordToWord8# 0x9a##-    {-# INLINE byteVal #-}-instance ByteVal 0x9b where-    byteVal _ = wordToWord8# 0x9b##-    {-# INLINE byteVal #-}-instance ByteVal 0x9c where-    byteVal _ = wordToWord8# 0x9c##-    {-# INLINE byteVal #-}-instance ByteVal 0x9d where-    byteVal _ = wordToWord8# 0x9d##-    {-# INLINE byteVal #-}-instance ByteVal 0x9e where-    byteVal _ = wordToWord8# 0x9e##-    {-# INLINE byteVal #-}-instance ByteVal 0x9f where-    byteVal _ = wordToWord8# 0x9f##-    {-# INLINE byteVal #-}-instance ByteVal 0xa0 where-    byteVal _ = wordToWord8# 0xa0##-    {-# INLINE byteVal #-}-instance ByteVal 0xa1 where-    byteVal _ = wordToWord8# 0xa1##-    {-# INLINE byteVal #-}-instance ByteVal 0xa2 where-    byteVal _ = wordToWord8# 0xa2##-    {-# INLINE byteVal #-}-instance ByteVal 0xa3 where-    byteVal _ = wordToWord8# 0xa3##-    {-# INLINE byteVal #-}-instance ByteVal 0xa4 where-    byteVal _ = wordToWord8# 0xa4##-    {-# INLINE byteVal #-}-instance ByteVal 0xa5 where-    byteVal _ = wordToWord8# 0xa5##-    {-# INLINE byteVal #-}-instance ByteVal 0xa6 where-    byteVal _ = wordToWord8# 0xa6##-    {-# INLINE byteVal #-}-instance ByteVal 0xa7 where-    byteVal _ = wordToWord8# 0xa7##-    {-# INLINE byteVal #-}-instance ByteVal 0xa8 where-    byteVal _ = wordToWord8# 0xa8##-    {-# INLINE byteVal #-}-instance ByteVal 0xa9 where-    byteVal _ = wordToWord8# 0xa9##-    {-# INLINE byteVal #-}-instance ByteVal 0xaa where-    byteVal _ = wordToWord8# 0xaa##-    {-# INLINE byteVal #-}-instance ByteVal 0xab where-    byteVal _ = wordToWord8# 0xab##-    {-# INLINE byteVal #-}-instance ByteVal 0xac where-    byteVal _ = wordToWord8# 0xac##-    {-# INLINE byteVal #-}-instance ByteVal 0xad where-    byteVal _ = wordToWord8# 0xad##-    {-# INLINE byteVal #-}-instance ByteVal 0xae where-    byteVal _ = wordToWord8# 0xae##-    {-# INLINE byteVal #-}-instance ByteVal 0xaf where-    byteVal _ = wordToWord8# 0xaf##-    {-# INLINE byteVal #-}-instance ByteVal 0xb0 where-    byteVal _ = wordToWord8# 0xb0##-    {-# INLINE byteVal #-}-instance ByteVal 0xb1 where-    byteVal _ = wordToWord8# 0xb1##-    {-# INLINE byteVal #-}-instance ByteVal 0xb2 where-    byteVal _ = wordToWord8# 0xb2##-    {-# INLINE byteVal #-}-instance ByteVal 0xb3 where-    byteVal _ = wordToWord8# 0xb3##-    {-# INLINE byteVal #-}-instance ByteVal 0xb4 where-    byteVal _ = wordToWord8# 0xb4##-    {-# INLINE byteVal #-}-instance ByteVal 0xb5 where-    byteVal _ = wordToWord8# 0xb5##-    {-# INLINE byteVal #-}-instance ByteVal 0xb6 where-    byteVal _ = wordToWord8# 0xb6##-    {-# INLINE byteVal #-}-instance ByteVal 0xb7 where-    byteVal _ = wordToWord8# 0xb7##-    {-# INLINE byteVal #-}-instance ByteVal 0xb8 where-    byteVal _ = wordToWord8# 0xb8##-    {-# INLINE byteVal #-}-instance ByteVal 0xb9 where-    byteVal _ = wordToWord8# 0xb9##-    {-# INLINE byteVal #-}-instance ByteVal 0xba where-    byteVal _ = wordToWord8# 0xba##-    {-# INLINE byteVal #-}-instance ByteVal 0xbb where-    byteVal _ = wordToWord8# 0xbb##-    {-# INLINE byteVal #-}-instance ByteVal 0xbc where-    byteVal _ = wordToWord8# 0xbc##-    {-# INLINE byteVal #-}-instance ByteVal 0xbd where-    byteVal _ = wordToWord8# 0xbd##-    {-# INLINE byteVal #-}-instance ByteVal 0xbe where-    byteVal _ = wordToWord8# 0xbe##-    {-# INLINE byteVal #-}-instance ByteVal 0xbf where-    byteVal _ = wordToWord8# 0xbf##-    {-# INLINE byteVal #-}-instance ByteVal 0xc0 where-    byteVal _ = wordToWord8# 0xc0##-    {-# INLINE byteVal #-}-instance ByteVal 0xc1 where-    byteVal _ = wordToWord8# 0xc1##-    {-# INLINE byteVal #-}-instance ByteVal 0xc2 where-    byteVal _ = wordToWord8# 0xc2##-    {-# INLINE byteVal #-}-instance ByteVal 0xc3 where-    byteVal _ = wordToWord8# 0xc3##-    {-# INLINE byteVal #-}-instance ByteVal 0xc4 where-    byteVal _ = wordToWord8# 0xc4##-    {-# INLINE byteVal #-}-instance ByteVal 0xc5 where-    byteVal _ = wordToWord8# 0xc5##-    {-# INLINE byteVal #-}-instance ByteVal 0xc6 where-    byteVal _ = wordToWord8# 0xc6##-    {-# INLINE byteVal #-}-instance ByteVal 0xc7 where-    byteVal _ = wordToWord8# 0xc7##-    {-# INLINE byteVal #-}-instance ByteVal 0xc8 where-    byteVal _ = wordToWord8# 0xc8##-    {-# INLINE byteVal #-}-instance ByteVal 0xc9 where-    byteVal _ = wordToWord8# 0xc9##-    {-# INLINE byteVal #-}-instance ByteVal 0xca where-    byteVal _ = wordToWord8# 0xca##-    {-# INLINE byteVal #-}-instance ByteVal 0xcb where-    byteVal _ = wordToWord8# 0xcb##-    {-# INLINE byteVal #-}-instance ByteVal 0xcc where-    byteVal _ = wordToWord8# 0xcc##-    {-# INLINE byteVal #-}-instance ByteVal 0xcd where-    byteVal _ = wordToWord8# 0xcd##-    {-# INLINE byteVal #-}-instance ByteVal 0xce where-    byteVal _ = wordToWord8# 0xce##-    {-# INLINE byteVal #-}-instance ByteVal 0xcf where-    byteVal _ = wordToWord8# 0xcf##-    {-# INLINE byteVal #-}-instance ByteVal 0xd0 where-    byteVal _ = wordToWord8# 0xd0##-    {-# INLINE byteVal #-}-instance ByteVal 0xd1 where-    byteVal _ = wordToWord8# 0xd1##-    {-# INLINE byteVal #-}-instance ByteVal 0xd2 where-    byteVal _ = wordToWord8# 0xd2##-    {-# INLINE byteVal #-}-instance ByteVal 0xd3 where-    byteVal _ = wordToWord8# 0xd3##-    {-# INLINE byteVal #-}-instance ByteVal 0xd4 where-    byteVal _ = wordToWord8# 0xd4##-    {-# INLINE byteVal #-}-instance ByteVal 0xd5 where-    byteVal _ = wordToWord8# 0xd5##-    {-# INLINE byteVal #-}-instance ByteVal 0xd6 where-    byteVal _ = wordToWord8# 0xd6##-    {-# INLINE byteVal #-}-instance ByteVal 0xd7 where-    byteVal _ = wordToWord8# 0xd7##-    {-# INLINE byteVal #-}-instance ByteVal 0xd8 where-    byteVal _ = wordToWord8# 0xd8##-    {-# INLINE byteVal #-}-instance ByteVal 0xd9 where-    byteVal _ = wordToWord8# 0xd9##-    {-# INLINE byteVal #-}-instance ByteVal 0xda where-    byteVal _ = wordToWord8# 0xda##-    {-# INLINE byteVal #-}-instance ByteVal 0xdb where-    byteVal _ = wordToWord8# 0xdb##-    {-# INLINE byteVal #-}-instance ByteVal 0xdc where-    byteVal _ = wordToWord8# 0xdc##-    {-# INLINE byteVal #-}-instance ByteVal 0xdd where-    byteVal _ = wordToWord8# 0xdd##-    {-# INLINE byteVal #-}-instance ByteVal 0xde where-    byteVal _ = wordToWord8# 0xde##-    {-# INLINE byteVal #-}-instance ByteVal 0xdf where-    byteVal _ = wordToWord8# 0xdf##-    {-# INLINE byteVal #-}-instance ByteVal 0xe0 where-    byteVal _ = wordToWord8# 0xe0##-    {-# INLINE byteVal #-}-instance ByteVal 0xe1 where-    byteVal _ = wordToWord8# 0xe1##-    {-# INLINE byteVal #-}-instance ByteVal 0xe2 where-    byteVal _ = wordToWord8# 0xe2##-    {-# INLINE byteVal #-}-instance ByteVal 0xe3 where-    byteVal _ = wordToWord8# 0xe3##-    {-# INLINE byteVal #-}-instance ByteVal 0xe4 where-    byteVal _ = wordToWord8# 0xe4##-    {-# INLINE byteVal #-}-instance ByteVal 0xe5 where-    byteVal _ = wordToWord8# 0xe5##-    {-# INLINE byteVal #-}-instance ByteVal 0xe6 where-    byteVal _ = wordToWord8# 0xe6##-    {-# INLINE byteVal #-}-instance ByteVal 0xe7 where-    byteVal _ = wordToWord8# 0xe7##-    {-# INLINE byteVal #-}-instance ByteVal 0xe8 where-    byteVal _ = wordToWord8# 0xe8##-    {-# INLINE byteVal #-}-instance ByteVal 0xe9 where-    byteVal _ = wordToWord8# 0xe9##-    {-# INLINE byteVal #-}-instance ByteVal 0xea where-    byteVal _ = wordToWord8# 0xea##-    {-# INLINE byteVal #-}-instance ByteVal 0xeb where-    byteVal _ = wordToWord8# 0xeb##-    {-# INLINE byteVal #-}-instance ByteVal 0xec where-    byteVal _ = wordToWord8# 0xec##-    {-# INLINE byteVal #-}-instance ByteVal 0xed where-    byteVal _ = wordToWord8# 0xed##-    {-# INLINE byteVal #-}-instance ByteVal 0xee where-    byteVal _ = wordToWord8# 0xee##-    {-# INLINE byteVal #-}-instance ByteVal 0xef where-    byteVal _ = wordToWord8# 0xef##-    {-# INLINE byteVal #-}-instance ByteVal 0xf0 where-    byteVal _ = wordToWord8# 0xf0##-    {-# INLINE byteVal #-}-instance ByteVal 0xf1 where-    byteVal _ = wordToWord8# 0xf1##-    {-# INLINE byteVal #-}-instance ByteVal 0xf2 where-    byteVal _ = wordToWord8# 0xf2##-    {-# INLINE byteVal #-}-instance ByteVal 0xf3 where-    byteVal _ = wordToWord8# 0xf3##-    {-# INLINE byteVal #-}-instance ByteVal 0xf4 where-    byteVal _ = wordToWord8# 0xf4##-    {-# INLINE byteVal #-}-instance ByteVal 0xf5 where-    byteVal _ = wordToWord8# 0xf5##-    {-# INLINE byteVal #-}-instance ByteVal 0xf6 where-    byteVal _ = wordToWord8# 0xf6##-    {-# INLINE byteVal #-}-instance ByteVal 0xf7 where-    byteVal _ = wordToWord8# 0xf7##-    {-# INLINE byteVal #-}-instance ByteVal 0xf8 where-    byteVal _ = wordToWord8# 0xf8##-    {-# INLINE byteVal #-}-instance ByteVal 0xf9 where-    byteVal _ = wordToWord8# 0xf9##-    {-# INLINE byteVal #-}-instance ByteVal 0xfa where-    byteVal _ = wordToWord8# 0xfa##-    {-# INLINE byteVal #-}-instance ByteVal 0xfb where-    byteVal _ = wordToWord8# 0xfb##-    {-# INLINE byteVal #-}-instance ByteVal 0xfc where-    byteVal _ = wordToWord8# 0xfc##-    {-# INLINE byteVal #-}-instance ByteVal 0xfd where-    byteVal _ = wordToWord8# 0xfd##-    {-# INLINE byteVal #-}-instance ByteVal 0xfe where-    byteVal _ = wordToWord8# 0xfe##-    {-# INLINE byteVal #-}-instance ByteVal 0xff where-    byteVal _ = wordToWord8# 0xff##-    {-# INLINE byteVal #-}--type family Length (a :: [k]) :: Natural where-    Length '[]       = 0-    Length (a ': as) = 1 + Length as---- | Efficiently reify a list of type-level '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#
− src/Binrep/Type/ByteString.hs 
@@ -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
− src/Binrep/Type/Common.hs 
@@ -1,10 +0,0 @@-module Binrep.Type.Common where--import GHC.Generics ( Generic )-import Data.Data ( Data )---- | Byte order.-data Endianness-  = BE -- ^    big endian, MSB first. e.g. most network protocols-  | LE -- ^ little endian, MSB last.  e.g. most processor architectures-    deriving stock (Generic, Data, Show, Eq)
+ src/Binrep/Type/Derived/NullTermPadded.hs view
@@ -0,0 +1,22 @@+{- | Null-terminated, then null-padded data.++This is defined using the composition of existing 'NullTerminate' and+'NullPad' predicates, plus the re-associating binrep instances for the 'And'+predicate combinator. It kind of just magically works.+-}++module Binrep.Type.Derived.NullTermPadded where++import Binrep.Type.NullTerminated+import Binrep.Type.NullPadded++import Rerefined.Predicate.Logical.And+import Rerefined.Refine ( Refined )++-- | Predicate for null-terminated, then null-padded data.+type NullTermPad n = NullTerminate `And` NullPad n++-- | Null-terminated data, which is then null-padded to the given length.+--+-- Instantiate with @ByteString@ for a null-padded C string.+type NullTermPadded n = Refined (NullTermPad n)
− src/Binrep/Type/Int.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--{- TODO can I replace this with a closed newtype family?? idk if I even want to-    it's just this is clumsy to use sometimes--}--module Binrep.Type.Int where--import Binrep-import Binrep.Type.Common ( Endianness(..) )-import Strongweak--import Data.Word-import Data.Int-import Data.Aeson-import FlatParse.Basic qualified as FP-import Mason.Builder qualified as Mason--import GHC.Generics ( Generic )-import Data.Data ( Typeable, Data )-import GHC.TypeNats---- | Wrapper type grouping machine integers (sign, size) along with an explicit---   endianness.------ The internal representation is selected via a type family to correspond to--- the relevant Haskell data type, so common overflow behaviour should match.--- We derive lots of handy instances, so you may perform regular arithmetic on--- pairs of these types. For example:------ >>> 255 + 1 :: I 'U 'I1 e--- 0------ >>> 255 + 1 :: I 'U 'I2 e--- 256-newtype I (sign :: ISign) (size :: ISize) (e :: Endianness)-  = I { getI :: IRep sign size }-    deriving stock (Generic)--deriving instance (Data (IRep sign size), Typeable sign, Typeable size, Typeable e) => Data (I sign size e)-deriving via (IRep sign size) instance Show     (IRep sign size) => Show     (I sign size e)---- Steal various numeric instances from the representation types.-deriving via (IRep sign size) instance Eq       (IRep sign size) => Eq       (I sign size e)-deriving via (IRep sign size) instance Ord      (IRep sign size) => Ord      (I sign size e)-deriving via (IRep sign size) instance Bounded  (IRep sign size) => Bounded  (I sign size e)-deriving via (IRep sign size) instance Num      (IRep sign size) => Num      (I sign size e)-deriving via (IRep sign size) instance Real     (IRep sign size) => Real     (I sign size e)-deriving via (IRep sign size) instance Enum     (IRep sign size) => Enum     (I sign size e)-deriving via (IRep sign size) instance Integral (IRep sign size) => Integral (I sign size e)---- | Unsigned machine integers can be idealized as naturals.-instance (irep ~ IRep 'U size, Integral irep) => Weaken (I 'U size end) where-    type Weak (I 'U size end) = Natural-    weaken = fromIntegral-instance (irep ~ IRep 'U size, Integral irep, Bounded irep, Show irep, Typeable size, Typeable end)-  => Strengthen (I 'U size end) where-      strengthen = strengthenBounded---- | Signed machine integers can be idealized as integers.-instance (irep ~ IRep 'S size, Integral irep) => Weaken (I 'S size end) where-    type Weak (I 'S size end) = Integer-    weaken = fromIntegral-instance (irep ~ IRep 'S size, Integral irep, Bounded irep, Show irep, Typeable size, Typeable end)-  => Strengthen (I 'S size end) where-      strengthen = strengthenBounded---- | Machine integer sign.-data ISign-  = S -- ^   signed-  | U -- ^ unsigned-    deriving stock (Generic, Data, Show, Eq)---- | Machine integer size in number of bytes.-data ISize = I1 | I2 | I4 | I8-    deriving stock (Generic, Data, Show, Eq)---- | Grouping for matching a signedness and size to a Haskell integer data type.-type family IRep (sign :: ISign) (size :: ISize) where-    IRep 'U 'I1 = Word8-    IRep 'S 'I1 =  Int8-    IRep 'U 'I2 = Word16-    IRep 'S 'I2 =  Int16-    IRep 'U 'I4 = Word32-    IRep 'S 'I4 =  Int32-    IRep 'U 'I8 = Word64-    IRep 'S 'I8 =  Int64---- Also steal Aeson instances. The parser applies bounding checks appropriately.-deriving via (IRep sign size) instance ToJSON   (IRep sign size) => ToJSON   (I sign size e)-deriving via (IRep sign size) instance FromJSON (IRep sign size) => FromJSON (I sign size e)--instance KnownNat (CBLen (I sign size end)) => BLen (I sign size end) where-    type CBLen (I sign size end) = CBLen (IRep sign size)--instance Put (I 'U 'I1 e) where put = put . getI-instance Get (I 'U 'I1 e) where get = I <$> get-instance Put (I 'S 'I1 e) where put = put . getI-instance Get (I 'S 'I1 e) where get = I <$> get--instance Put (I 'U 'I2 'BE) where put (I i) = Mason.word16BE i-instance Get (I 'U 'I2 'BE) where get = I <$> 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 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 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)---- | Shortcut.-type family IMax (sign :: ISign) (size :: ISize) :: Natural where-    IMax sign size = MaxBound (IRep sign size)---- | Restricted reflected version of @maxBound@.-type family MaxBound w :: Natural where-    MaxBound Word8  = 255-    MaxBound  Int8  = 127-    MaxBound Word16 = 65535-    MaxBound  Int16 = 32767-    MaxBound Word32 = 4294967295-    MaxBound  Int32 = 2147483647-    MaxBound Word64 = 18446744073709551615-    MaxBound  Int64 = 9223372036854775807
− src/Binrep/Type/LenPfx.hs 
@@ -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
src/Binrep/Type/Magic.hs view
@@ -1,119 +1,94 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-} -- for tons of stuff+{-# LANGUAGE PatternSynonyms #-} -- TODO wip+{-# LANGUAGE OverloadedStrings #-} -- for easy error building  {- | 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@-  * printable ASCII bytes e.g. Ogg: @4F 67 67 53@ -> OggS--For bytewise magics, use type-level 'Natural' lists.-For ASCII magics, use 'Symbol's (type-level strings).--Previously, I squashed these into a representationally-safe type. Now the check-only occurs during reification. So you are able to define invalid magics now-(bytes over 255, non-ASCII characters), and potentially use them, but you'll get-a clear type error like "no instance for ByteVal 256" when attempting to reify.+  * byte magics e.g. Zstandard: @28 B5 2F FD@+  * printable magics e.g. Ogg: @4F 67 67 53@ -> @OggS@ (in ASCII) -String magics are restricted to ASCII, and will type error during reification-otherwise. If you really want UTF-8, please read 'Binrep.Type.Magic.UTF8'.+For byte magics, use type-level 'Natural' lists e.g. @'Magic' \@'[0xFF, 0x01]@+For printable (UTF-8) magics, use 'Symbol's e.g. @'Magic' \@"hello"@. -} -module Binrep.Type.Magic where+module Binrep.Type.Magic+  ( Magic(Magic)+  , Magical(type MagicBytes)+  , type Length+  ) where -import Binrep-import Binrep.Type.Byte+import Data.Type.Symbol.Utf8 ( type SymbolToUtf8 ) -import GHC.TypeLits-import Data.ByteString qualified as B-import FlatParse.Basic qualified as FP+import GHC.TypeLits ( type Natural, type Symbol, type KnownNat, type (+) )  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.------ The phantom type variable unambiguously defines a short, constant bytestring.--- A handful of types are supported for using magics conveniently, e.g. for pure--- ASCII magics, you may use a 'Symbol' type-level string.-data Magic (a :: k) = Magic-    deriving stock (Generic, Data, Show, Eq)---- | Weaken a 'Magic a' to the unit. Perhaps you prefer pattern matching on @()@---   over @Magic@, or wish a weak type to be fully divorced from its binrep---   origins.-instance Weaken (Magic a) where-    type Weak (Magic a) = ()-    weaken _ = ()---- | Strengthen the unit to some 'Magic a'.-instance Strengthen (Magic a) where-    strengthen _ = pure Magic--instance (KnownNat (Length (MagicBytes a))) => BLen (Magic a) where-    type CBLen (Magic a) = Length (MagicBytes 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-    get = do-        let expected = Mason.toStrictByteString $ reifyBytes @bs-        actual <- FP.takeBs $ B.length expected-        if   actual == expected-        then return Magic-        else eBase $ EExpected expected actual+import Binrep+import Bytezap.Struct.TypeLits.Bytes ( ReifyBytesW64(reifyBytesW64) )+import Bytezap.Parser.Struct.TypeLits.Bytes+  ( ParseReifyBytesW64(parseReifyBytesW64) )+import Bytezap.Parser.Struct qualified as BZ+import GHC.Exts ( Int(I#) )+import FlatParse.Basic qualified as FP+import Data.Text.Builder.Linear qualified as TBL -{--I do lots of functions on lists, because they're structurally simple. But you-can't pass type-level functions as arguments between type families. singletons-solves a related (?) problem using defunctionalization, where you manually write-out the function applications or something. Essentially, you can't do this:+{- | A unit data type representing a "magic number" via a phantom type. -    type family Map (f :: x -> y) (a :: [x]) :: [y] where-        Map _ '[]       = '[]-        Map f (a ': as) = f a ': Map f as+The phantom type unambiguously defines a bytestring at compile time. This+depends on the type's kind. See 'MagicBytes' for details. -So you have to write that out for every concrete function over lists.+This is defined using GADT syntax to permit labelling the phantom type kind as+/inferred/, which effectively means hidden (not available for visible type+applications). That kind is always evident from the type, so it's just nicer. -}+data Magic a where Magic :: forall {k} (a :: k). Magic a+    deriving stock (Generic, Data, Show, Eq) -type family SymbolUnicodeCodepoints (a :: Symbol) :: [Natural] where-    SymbolUnicodeCodepoints a = CharListUnicodeCodepoints (SymbolAsCharList a)+-- | The byte length of a magic is known at compile time.+instance IsCBLen (Magic a) where type CBLen (Magic a) = Length (MagicBytes a) -type family CharListUnicodeCodepoints (a :: [Char]) :: [Natural] where-    CharListUnicodeCodepoints '[]       = '[]-    CharListUnicodeCodepoints (c ': cs) = CharToNat c ': CharListUnicodeCodepoints cs+deriving via ViaCBLen (Magic a) instance+    KnownNat (Length (MagicBytes a)) => BLen (Magic a) -type family SymbolAsCharList (a :: Symbol) :: [Char] where-    SymbolAsCharList a = SymbolAsCharList' (UnconsSymbol a)+-- | Efficiently serialize a @'Magic' a@.+instance (bs ~ MagicBytes a, ReifyBytesW64 bs) => PutC (Magic a) where+    putC Magic = reifyBytesW64 @bs -type family SymbolAsCharList' (a :: Maybe (Char, Symbol)) :: [Char] where-    SymbolAsCharList' 'Nothing = '[]-    SymbolAsCharList' ('Just '(c, s)) = c ': SymbolAsCharList' (UnconsSymbol s)+deriving via (ViaPutC (Magic a)) instance+  (bs ~ MagicBytes a, ReifyBytesW64 bs, KnownNat (Length bs)) => Put (Magic a) ---------------------------------------------------------------------------------+-- | Efficiently parse a @'Magic' a@. Serialization constraints are included as+--   we emit the expected bytestring in errors.+instance (bs ~ MagicBytes a, ParseReifyBytesW64 0 bs) => GetC (Magic a) where+    getC = BZ.ParserT $ \fpc base# os# st0 ->+        case BZ.runParserT# (parseReifyBytesW64 @0 @bs) fpc base# os# st0 of+          BZ.OK#   st1 ()             -> BZ.OK#   st1 Magic+          BZ.Err#  st1 (pos, bActual) -> BZ.Err#  st1 (parseError1+            ["TODO magic parse error: "<>TBL.fromDec bActual]+            (pos + I# os#))+          BZ.Fail# st1                -> BZ.Fail# st1 -- shouldn't occur +deriving via ViaGetC (Magic a) instance+  ( bs ~ MagicBytes a, ParseReifyBytesW64 0 bs+  , ReifyBytesW64 bs, KnownNat (Length bs)+  ) => Get (Magic a)+ -- | Types which define a magic value. class Magical (a :: k) where-    -- | How to turn the type into a list of bytes.+    -- | How to turn the type into a list of bytes (stored using 'Natural's).     type MagicBytes a :: [Natural]  -- | Type-level naturals go as-is. (Make sure you don't go over 255, though!)-instance Magical (ns :: [Natural]) where-    type MagicBytes ns = ns+instance Magical (bs :: [Natural]) where type MagicBytes bs = bs --- | Type-level symbols are turned into their Unicode codepoints - but---   multibyte characters aren't handled, so they'll simply be overlarge bytes,---   which will fail further down.-instance Magical (sym :: Symbol) where-    type MagicBytes sym = SymbolUnicodeCodepoints sym+-- | Type-level symbols are converted to UTF-8.+instance Magical (sym :: Symbol) where type MagicBytes sym = SymbolToUtf8 sym++-- | The length of a type-level list.+type family Length (a :: [k]) :: Natural where+    Length (a ': as) = 1 + Length as+    Length '[]       = 0
− src/Binrep/Type/Magic/UTF8.hs 
@@ -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
src/Binrep/Type/NullPadded.hs view
@@ -1,69 +1,93 @@-{-# LANGUAGE OverloadedStrings #-}+-- | Data null-padded to a given length. +{-# LANGUAGE UndecidableInstances #-} -- for PredicateName+{-# LANGUAGE OverloadedStrings #-} -- for refine error builder+ module Binrep.Type.NullPadded where  import Binrep-import Binrep.Util ( tshow )+import Bytezap.Poke qualified as BZ+import Bytezap.Struct qualified as BZ.Struct+import FlatParse.Basic qualified as FP+import Raehik.Compat.FlatParse.Basic.WithLength qualified as FP+import Control.Monad.Combinators ( skipCount ) -import Refined-import Refined.Unsafe+import Rerefined.Predicate.Common+import Rerefined.Refine+import TypeLevelShow.Natural+import TypeLevelShow.Utils+import Data.Text.Builder.Linear qualified as TBL  import GHC.TypeNats-import Data.Typeable ( typeRep )-import FlatParse.Basic qualified as FP-import FlatParse.Basic ( Parser )-import Mason.Builder qualified as Mason-import Data.ByteString qualified as BS+import Util.TypeNats ( natValInt ) +import Bytezap.Parser.Struct qualified as BZG+import GHC.Exts ( Int(I#) )+ data NullPad (n :: Natural)+instance Predicate (NullPad n) where+    type PredicateName d (NullPad n) = ShowParen (d > 9)+        ("NullPad " ++ ShowNatDec n) +{- | A type which is to be null-padded to a given total length.++Given some @a :: 'NullPadded' n a@, it is guaranteed that++@+'blen' a '<=' 'natValInt' \@n+@++thus++@+'natValInt' \@n '-' 'blen' a '>=' 0+@++That is, the serialized stored data will not be longer than the total length.+-} type NullPadded n a = Refined (NullPad n) a -instance 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 IsCBLen (NullPadded n a) where type CBLen (NullPadded n a) = n+deriving via ViaCBLen (NullPadded n a) instance KnownNat n => BLen (NullPadded n a) -instance (BLen a, KnownNat n) => Predicate (NullPad n) a where-    validate p a-      | len > n-          = throwRefineOtherException (typeRep p) $-                   "too long: " <> tshow len <> " > " <> tshow n-      | otherwise = success+-- | Assert that term will fit.+instance (KnownPredicateName (NullPad n), BLen a, KnownNat n)+  => Refine (NullPad n) a where+    validate p a = validateBool p (len <= n) $+        "too long: " <> TBL.fromDec len <> " > " <> TBL.fromDec n       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, KnownNat n, Put a) => PutC (NullPadded n a) where+    putC ra = BZ.Struct.sequencePokes (BZ.toStructPoke (put a)) len+        (BZ.Struct.replicateByte paddingLen 0x00)       where-        n = typeNatToBLen @n+        a = unrefine ra+        len = blen a+        paddingLen = natValInt @n - len+        -- ^ 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-    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)+instance (BLen a, KnownNat n, Put a) => Put (NullPadded n a) where+    put ra = put a <> BZ.replicateByte paddingLen 0x00       where-        n = typeNatToBLen @n+        a = unrefine ra+        paddingLen = natValInt @n - blen a+        -- ^ refinement guarantees >=0 -getNNulls :: BLenT -> Parser E ()-getNNulls = \case 0 -> return ()-                  n -> FP.anyWord8 >>= \case-                         0x00    -> getNNulls $ n-1-                         nonNull -> eBase $ EExpectedByte 0x00 nonNull+-- | Run a @Getter a@ isolated to @n@ bytes.+instance (KnownNat n, Get a) => GetC (NullPadded n a) where+    getC = fpToBz get len# $ \a _unconsumed# ->+        -- TODO consume nulls lol+        BZG.constParse $ unsafeRefine a+      where+        !(I# len#) = natValInt @n++instance (Get a, KnownNat n) => Get (NullPadded n a) where+    get = do+        (a, len) <- FP.parseWithLength get+        let paddingLen = natValInt @n - len+        if   paddingLen < 0+        then err1 ["TODO used to be EOverlong, cba"]+        else do skipCount paddingLen (FP.word8 0x00)+                pure $ unsafeRefine a
+ src/Binrep/Type/NullTerminated.hs view
@@ -0,0 +1,72 @@+{- | 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 FlatParse.Basic qualified as FP++import Rerefined.Predicate.Common+import Rerefined.Refine++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++instance Predicate NullTerminate where+    type PredicateName d NullTerminate = "NullTerminate"++type NullTerminated = Refined NullTerminate++-- | Null-terminated data may not contain any null bytes.+instance Refine NullTerminate B.ByteString where+    -- TODO is there a faster check we can conjure up here...?+    validate p a = validateBool p (not (B.any (== 0x00) a)) $+        "null byte not permitted in null-terminated data"++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++-- | We may parse any null-terminated data using a special flatparse combinator.+--+-- The combinator doesn't permit distinguishing between the two possible+-- failures: either there was no next null, or the inner parser didn't consume+-- up to it.+instance Get a => Get (NullTerminated a) where+    {-# INLINE get #-}+    get = unsafeRefine <$> cut1 (FP.isolateToNextNull get) e+      where e = [ "while isolating to next null"+                , "either there was no next null in the input,"+                , "or the inner parser didn't fully consume its input" ]++{-+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+-}
+ src/Binrep/Type/Prefix/Count.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE UndecidableInstances #-} -- required for type-level stuff+{-# LANGUAGE OverloadedStrings #-} -- required for refined errors++module Binrep.Type.Prefix.Count where++import Binrep.Type.Prefix.Internal+import Binrep+import Control.Monad.Combinators qualified as Monad++import GHC.TypeNats+import Util.TypeNats ( natValInt )++import Rerefined.Predicate.Common+import Rerefined.Refine+import TypeLevelShow.Utils++import Data.Kind ( type Type )++import Data.Foldable qualified as Foldable++-- TODO put monofoldable in here, instead of that useless @(f a)@ stuff++data CountPrefix (pfx :: Type)++instance Predicate (CountPrefix pfx) where+    type PredicateName d (CountPrefix pfx) = ShowParen (d > 9)+        ("CountPrefix " ++ LenNatName pfx)++instance+  ( KnownPredicateName (CountPrefix pfx), KnownNat (LenNatMax pfx), Foldable f+  ) => Refine1 (CountPrefix pfx) f where+    validate1 p fa =+        validateBool p (Foldable.length fa <= natValInt @(LenNatMax pfx)) $+            "TODO too large for count prefix"++instance+  ( KnownPredicateName (CountPrefix pfx), KnownNat (LenNatMax pfx), Foldable f+  ) => Refine (CountPrefix pfx) (f a) where+    validate = validate1++type CountPrefixed pfx = Refined1 (CountPrefix pfx)++-- | We can know byte length at compile time /if/ we know it for the prefix and+--   the list-like.+--+-- This is extremely unlikely, because then what counting are we even+-- performing for the list-like? But it's a valid instance.+instance IsCBLen (CountPrefixed pfx f a) where+    type CBLen (CountPrefixed pfx f a) = CBLen pfx + CBLen (f a)++-- | The byte length of a count-prefixed type is the length of the prefix type+--   (holding the length of the type) plus the length of the type.+--+-- Bit confusing. How to explain this? TODO+instance (LenNat pfx, Foldable f, BLen pfx, BLen (f a))+  => BLen (CountPrefixed pfx f a) where+    blen rfa = blen (lenToNat @pfx (Foldable.length fa)) + blen fa+      where fa = unrefine1 rfa++instance (LenNat pfx, Foldable f, Put pfx, Put (f a))+  => Put (CountPrefixed pfx f a) where+    put rfa = put (lenToNat @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 (LenNat pfx, GetCount f, Get pfx, Get a)+  => Get (CountPrefixed pfx f a) where+    get = do+        pfx <- get @pfx+        fa <- getCount (natToLen pfx)+        pure $ unsafeRefine1 fa
+ src/Binrep/Type/Prefix/Internal.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE UndecidableInstances #-} -- for convenient type level arithmetic++module Binrep.Type.Prefix.Internal where++import Binrep.Util.ByteOrder ( ByteOrdered(ByteOrdered) )+import GHC.TypeNats+import GHC.TypeLits ( type Symbol )+import Data.Word+import Data.Kind ( type Type )++-- | Types which can encode natural (positive integer) lengths.+--+-- Types must provide convert to and from 'Int', which is the most common type+-- used for data lengths.+class LenNat a where+    -- | The maximum value the type can encode.+    type LenNatMax a :: Natural++    -- | The name of the type, to display when used as part of a predicate.+    type LenNatName a :: Symbol++    -- | Turn an 'Int' length into an @a@.+    --+    -- It is guaranteed that the 'Int' fits i.e. @<= 'LenNatMax' a@.+    lenToNat :: Int -> a++    -- | Turn an @a@ into an 'Int' length.+    --+    -- Don't worry if @a@ may encode larger numbers than 'Int'. I think other+    -- things will be breaking at that point. Or perhaps it's our responsibility+    -- to emit the runtime error? TODO.+    natToLen :: a -> Int++-- | The unit can only encode 1 value -> lengths of 0 only.+instance LenNat () where+    type LenNatMax  () = 0+    type LenNatName () = "()"+    lenToNat = \case+      0 -> ()+      _ -> error "you lied to refine and broke everything :("+    natToLen () = 0++-- | Byte ordering doesn't change how prefixes work.+deriving via (a :: Type) instance LenNat a => LenNat (ByteOrdered end a)++instance LenNat Word8  where+    type LenNatMax  Word8  = 2^8  - 1+    type LenNatName Word8 = "Word8"+    lenToNat = fromIntegral+    natToLen = fromIntegral+instance LenNat Word16 where+    type LenNatMax  Word16 = 2^16 - 1+    type LenNatName Word16 = "Word16"+    lenToNat = fromIntegral+    natToLen = fromIntegral+instance LenNat Word32 where+    type LenNatMax  Word32 = 2^32 - 1+    type LenNatName Word32 = "Word32"+    lenToNat = fromIntegral+    natToLen = fromIntegral -- TODO check for overflow?+instance LenNat Word64 where+    type LenNatMax  Word64 = 2^64 - 1+    type LenNatName Word64 = "Word64"+    lenToNat = fromIntegral+    natToLen = fromIntegral -- TODO check for overflow?
+ src/Binrep/Type/Prefix/Size.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE UndecidableInstances #-} -- required for type-level stuff+{-# LANGUAGE OverloadedStrings #-} -- required for refined errors++module Binrep.Type.Prefix.Size where++import Binrep.Type.Prefix.Internal+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 Rerefined.Predicate.Common+import Rerefined.Refine+import TypeLevelShow.Utils++import Data.Kind ( type Type )++data SizePrefix (pfx :: Type)++instance Predicate (SizePrefix pfx) where+    type PredicateName d (SizePrefix pfx) = ShowParen (d > 9)+        ("SizePrefix " ++ LenNatName pfx)++type SizePrefixed pfx = Refined (SizePrefix pfx)++instance+  ( KnownPredicateName (SizePrefix pfx), KnownNat (LenNatMax pfx), BLen a+  ) => Refine (SizePrefix pfx) a where+    validate p a = validateBool p (blen a <= natValInt @(LenNatMax pfx)) $+        "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 (LenNat pfx, BLen a, BLen pfx)+  => BLen (SizePrefixed pfx a) where+    blen ra = blen (lenToNat @pfx (blen a)) + blen a+      where a = unrefine ra++instance (LenNat pfx, BLen a, Put pfx, Put a)+  => Put (SizePrefixed pfx a) where+    put ra = put (lenToNat @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 (LenNat pfx, GetSize a, Get pfx)+  => Get (SizePrefixed pfx a) where+    get = do+        pfx <- get @pfx+        a <- getSize (natToLen pfx)+        pure $ unsafeRefine a
src/Binrep/Type/Sized.hs view
@@ -1,42 +1,51 @@ -- | Constant-size data. -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for PredicateName+{-# LANGUAGE OverloadedStrings #-} -- for refine error builder  module Binrep.Type.Sized where  import Binrep-import Binrep.Util ( tshow )+import FlatParse.Basic qualified as FP -import Refined-import Refined.Unsafe+import Rerefined.Predicate.Common+import Rerefined.Refine+import TypeLevelShow.Natural+import TypeLevelShow.Utils+import Data.Text.Builder.Linear qualified as TBL  import GHC.TypeNats-import Data.Typeable ( typeRep )-import FlatParse.Basic qualified as FP+import Util.TypeNats ( natValInt ) +-- | Essentially runtime reflection of a 'BLen' type to 'CBLen'. data Size (n :: Natural) -type Sized n a = Refined (Size n) a+instance Predicate (Size n) where+    type PredicateName d (Size n) = ShowParen (d > 9)+        ("Size " ++ ShowNatDec n) -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-        = throwRefineOtherException (typeRep p) $-            "not correctly sized: "<>tshow len<>" /= "<>tshow n-     | otherwise = success+instance (KnownPredicateName (Size n), BLen a, KnownNat n)+  => Refine (Size n) a where+    validate p a = validateBool p (len == n) $+        "not correctly sized: "<>TBL.fromDec len<>" /= "<>TBL.fromDec n       where-        n = typeNatToBLen @n+        n = natValInt @n         len = blen a +instance IsCBLen (Sized n a) where type CBLen (Sized n a) = n+deriving via ViaCBLen (Sized n a) instance KnownNat n => BLen (Sized n a)++instance PutC a => PutC (Sized n a) where+    putC = putC . unrefine+ 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 $ unsafeRefine a+        -- ^ REFINE SAFETY: 'FP.isolate' consumes precisely the number of bytes+        -- requested when it succeeds
src/Binrep/Type/Text.hs view
@@ -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 Rerefined -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-    .  (Encode enc, Predicate rep Bytes)+    :: forall rep enc+    .  (Encode enc, Refine rep Bytes)     => AsText enc-    -> Either RefineException (Refined rep Bytes)+    -> Either RefineFailure (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
+ src/Binrep/Type/Text/Encoding/Ascii.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Binrep.Type.Text.Encoding.Ascii where++import Binrep.Type.Text.Internal+import Binrep.Type.Text.Encoding.Utf8++import Rerefined.Predicate.Common+import Rerefined.Refine ( unsafeRefine )++import Data.Text qualified as Text+import Data.Text ( Text )++import Data.Text.Encoding qualified as Text++-- | 7-bit+data Ascii+instance Predicate Ascii where type PredicateName d Ascii = "ASCII"++-- | 'Text' must be validated if you want to permit 7-bit ASCII only.+instance Refine Ascii Text where+    validate p t = validateBool p (Text.isAscii t) "not valid 7-bit ASCII"++-- | We reuse UTF-8 encoding for ASCII, since it is a subset of UTF-8.+instance Encode Ascii where encode' = encode' @Utf8++instance Decode Ascii where+    decode bs =+        case Text.decodeASCII' bs of+          Just t  -> Right $ unsafeRefine t+          Nothing -> Left  "not valid 7-bit ASCII"
+ src/Binrep/Type/Text/Encoding/ShiftJis.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}++module Binrep.Type.Text.Encoding.ShiftJis where++import Rerefined.Predicate++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+instance Predicate ShiftJis where type PredicateName d ShiftJis = "Shift-JIS"++-- | TODO Unsafely assume all 'Text's are valid Shift-JIS.+instance Refine ShiftJis Text where validate _ _ = Nothing++#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
+ src/Binrep/Type/Text/Encoding/Utf16.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE UndecidableInstances #-} -- for PredicateName++module Binrep.Type.Text.Encoding.Utf16 where++import Binrep.Type.Text.Internal+import Binrep.Util.ByteOrder++import Rerefined.Predicate+import TypeLevelShow.Utils++import Data.Text.Encoding qualified as Text+import Data.Text ( Text )++data Utf16 (end :: ByteOrder)+instance Predicate (Utf16 end) where+    type PredicateName d (Utf16 end) = "UTF-16" ++ EndianSuffix end++-- | Any 'Text' value is always valid UTF-16.+instance Refine (Utf16 end) Text where validate _ _ = Nothing++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
+ src/Binrep/Type/Text/Encoding/Utf32.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE UndecidableInstances #-} -- for PredicateName++module Binrep.Type.Text.Encoding.Utf32 where++import Binrep.Type.Text.Internal+import Binrep.Util.ByteOrder++import Rerefined.Predicate+import TypeLevelShow.Utils++import Data.Text.Encoding qualified as Text+import Data.Text ( Text )++data Utf32 (end :: ByteOrder)+instance Predicate (Utf32 end) where+    type PredicateName d (Utf32 end) = "UTF-32" ++ EndianSuffix end++-- | Any 'Text' value is always valid UTF-32.+instance Refine (Utf32 end) Text where validate _ _ = Nothing++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
+ src/Binrep/Type/Text/Encoding/Utf8.hs view
@@ -0,0 +1,17 @@+module Binrep.Type.Text.Encoding.Utf8 where++import Binrep.Type.Text.Internal++import Rerefined.Predicate++import Data.Text.Encoding qualified as Text+import Data.Text ( Text )++data Utf8+instance Predicate Utf8 where type PredicateName d Utf8 = "UTF-8"++-- | Any 'Text' value is always valid UTF-8.+instance Refine Utf8 Text where validate _ _ = Nothing++instance Encode Utf8 where encode' = Text.encodeUtf8+instance Decode Utf8 where decode  = decodeText show Text.decodeUtf8'
+ src/Binrep/Type/Text/Internal.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Binrep.Type.Text.Internal where++import Data.Text ( Text )+import Data.ByteString qualified as B+import Rerefined.Refine++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 unsafeRefine . 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
+ src/Binrep/Type/Thin.hs view
@@ -0,0 +1,43 @@+{- | "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.+-}++module Binrep.Type.Thin where++import Binrep++import FlatParse.Basic qualified as FP++import GHC.Generics ( Generic )+import Data.Data ( Data )+import GHC.Exts ( IsList )+import Data.String+import Control.DeepSeq++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++instance Get (Thin B.ByteString) where get = Thin <$> FP.takeRest
− src/Binrep/Type/Varint.hs 
@@ -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
− src/Binrep/Type/Vector.hs 
@@ -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
− src/Binrep/Util.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Binrep.Util where---- tshow-import Data.Text qualified as Text-import Data.Text ( Text )---- posIntToNat-import GHC.Exts ( Int(..), int2Word# )-import GHC.Num.Natural ( Natural(..) )---- natVal''-import GHC.TypeNats ( KnownNat, natVal' )-import GHC.Exts ( proxy#, Proxy# )--tshow :: Show a => a -> Text-tshow = Text.pack . show---- | Convert some 'Int' @i@ where @i >= 0@ to a 'Natural'.------ This is intended for wrapping the output of 'length' functions.------ underflows if you call it with a negative 'Int' :)-posIntToNat :: Int -> Natural-posIntToNat (I# i#) = NS (int2Word# i#)-{-# INLINE posIntToNat #-}--natVal'' :: forall a. KnownNat a => Natural-natVal'' = natVal' (proxy# :: Proxy# a)-{-# INLINE natVal'' #-}
+ src/Binrep/Util/ByteOrder.hs view
@@ -0,0 +1,17 @@+module Binrep.Util.ByteOrder+  ( ByteOrder(..), ByteOrdered(..), type EndianSuffix+  , type LE, type BE, type Endian+  ) where++import Raehik.Compat.Data.Primitive.Types.Endian ( ByteOrdered(..) )+import GHC.ByteOrder ( ByteOrder(..) )+import GHC.TypeLits ( type Symbol )++-- shorter names I originally used+type LE = LittleEndian+type BE =    BigEndian+type Endian = ByteOrdered++type family EndianSuffix (end :: ByteOrder) :: Symbol where+    EndianSuffix LittleEndian = "LE"+    EndianSuffix    BigEndian = "BE"
+ src/Binrep/Util/Generic.hs view
@@ -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"
− src/Data/Aeson/Extra/SizedVector.hs 
@@ -1,19 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Data.Aeson.Extra.SizedVector where--import Data.Aeson-import Data.Vector.Generic.Sized.Internal qualified as VSI-import Data.Vector.Generic.Sized qualified as VS-import Data.Vector.Generic qualified as V-import GHC.TypeNats ( KnownNat )--instance ToJSON   (v a) => ToJSON   (VSI.Vector v n a) where-    toJSON     (VSI.Vector v) = toJSON     v-    toEncoding (VSI.Vector v) = toEncoding v-instance (FromJSON (v a), KnownNat n, V.Vector v a) => FromJSON (VSI.Vector v n a) where-    parseJSON j = do-        v <- parseJSON j-        case VS.toSized v of-          Nothing -> fail "TODO bad size"-          Just v' -> return v'
− src/Haskpatch/Format/Bps.hs 
@@ -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)-  }
− src/Haskpatch/Format/Vcdiff.hs 
@@ -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
+ src/Raehik/Compat/FlatParse/Basic/CutWithPos.hs view
@@ -0,0 +1,15 @@+module Raehik.Compat.FlatParse.Basic.CutWithPos where++import FlatParse.Basic ( ParserT, Pos, getPos, cut, err )++-- | Convert a parsing failure to an error, which also receives the parser+--   position (as a 'Pos', from the end of input).+cut' :: ParserT st e a -> (Pos -> e) -> ParserT st e a+cut' p e = getPos >>= \pos -> cut p (e pos)+{-# inline cut' #-}++-- | Throw a parsing error, which also receives the parser position (as a 'Pos',+--   from the end of input).+err' :: (Pos -> e) -> ParserT st e a+err' e = getPos >>= \pos -> err (e pos)+{-# inline err' #-}
+ src/Raehik/Compat/FlatParse/Basic/Prim.hs view
@@ -0,0 +1,11 @@+module Raehik.Compat.FlatParse.Basic.Prim where++import Raehik.Compat.Data.Primitive.Types+import FlatParse.Basic+import GHC.Exts ( plusAddr# )++anyPrim :: forall a e st. Prim' a => ParserT st e a+anyPrim = withEnsure# size# $ ParserT $ \_fp _eob buf st ->+    OK# st (indexWord8OffAddrAs# buf 0#) (buf `plusAddr#` size#)+  where+    size# = sizeOf# (undefined :: a)
+ src/Raehik/Compat/FlatParse/Basic/Remaining.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE PatternSynonyms #-}++module Raehik.Compat.FlatParse.Basic.Remaining where++import FlatParse.Basic.Parser ( ParserT(ParserT), pattern OK# )+import GHC.Exts ( minusAddr#, Int(I#) )++-- | Get the remaining length. May return 0.+remaining :: ParserT st e Int+remaining = ParserT $ \_fp eob s st -> OK# st (I# (minusAddr# eob s)) s+{-# inline remaining #-}
+ src/Raehik/Compat/FlatParse/Basic/WithLength.hs view
@@ -0,0 +1,15 @@+-- | https://github.com/AndrasKovacs/flatparse/pull/56+module Raehik.Compat.FlatParse.Basic.WithLength where++import FlatParse.Basic.Parser+import GHC.Exts++-- | Run a parser, and return the result as well as the number of bytes it+--   consumed.+parseWithLength :: ParserT st e a -> ParserT st e (a, Int)+parseWithLength (ParserT f) = ParserT $ \fp eob s st -> do+    case f fp eob s st of+      Fail# st'      -> Fail# st'+      Err#  st' e    -> Err#  st' e+      OK#   st' a s' -> OK#   st' (a, I# (s' `minusAddr#` s)) s'+{-# inline parseWithLength #-}
− src/Util/Generic.hs 
@@ -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
+ src/Util/TypeNats.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- for my TypeApplications-based natVals++-- | 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 #-}++natValWord :: forall n. KnownNat n => Word+natValWord = fromIntegral $ natVal'' @n+{-# INLINE natValWord #-}
test/ArbitraryOrphans.hs view
@@ -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.Util.ByteOrder ( ByteOrdered(..) )+import Data.Kind ( Type ) --- | 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 (ByteOrdered end a)+--deriving newtype instance Arbitrary a => Arbitrary (Endian end a)
− test/Binrep/Extra/HexByteStringSpec.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Binrep.Extra.HexByteStringSpec ( spec ) where--import Binrep.Extra.HexByteString-import Test.Hspec--import Data.ByteString qualified as B-import Text.Megaparsec-import Data.Void ( Void )--megaparsecParseFromCharStream :: forall s a. (Stream s, Token s ~ Char) => Parsec Void s a -> s -> Maybe a-megaparsecParseFromCharStream parser text = parseMaybe parser text--spec :: Spec-spec = do-    let bs = B.pack-    describe "parse" $ do-      let p = megaparsecParseFromCharStream @String (parseHexByteString B.pack)-      it "parses valid hex bytestrings" $ do-        p "00" `shouldBe` Just (bs [0x00])-        p "FF" `shouldBe` Just (bs [0xFF])-        p "1234" `shouldBe` Just (bs [0x12, 0x34])-        p "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE])-        p "FFFFFFFF" `shouldBe` Just (B.replicate 4 0xFF)-        p "12 34    AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD])-      it "fails to parse invalid hex bytestrings" $ do-        p "-00" `shouldBe` Nothing-        p "FG" `shouldBe` Nothing-      it "fails to parse 0x prefix" $ do-        p   "1234" `shouldBe` Just (bs [0x12, 0x34])-        p "0x1234" `shouldBe` Nothing-    describe "print" $ do-      it "prints pretty hex bytestrings" $ do-        let p = prettyHexByteString B.unpack-        p (bs [0x5a, 0x7d]) `shouldBe` "5A 7D"-      it "prints compact hex bytestrings" $ do-        let pc = prettyHexByteStringCompact B.unpack-        pc (bs [0xab, 0x25]) `shouldBe` "ab25"
+ test/Binrep/GenericSpec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Binrep.GenericSpec where++import Test.Hspec++spec :: Spec+spec = pure ()+    {-+spec = do+    prop "parse-print roundtrip isomorphism (generic, sum tag via nullterm constructor)" $ do+      \(d :: D) -> runGet (runPut d) `shouldBe` Right (d, "")++--------------------------------------------------------------------------------++type W1   = Word8+type W2LE = ByteOrdered LE Word16+type W8BE = ByteOrdered BE Word64++data D+  = D01Bla     Word8 W1 W8BE+  | D23        W2LE  B.ByteString -- dangerous bytestring, must be last+  | DUnicode例 Word8+  | DSymbols_#+    deriving stock (Generic, Eq, Show)+deriving via (GenericArbitraryU `AndShrinking` D) instance Arbitrary D++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+    deriving stock (Generic, Eq, Show)+deriving via (GenericArbitraryU `AndShrinking` DNoSum) instance Arbitrary DNoSum++instance BLen DNoSum where blen = blenGenericNonSum+instance Put  DNoSum where put  = putGenericNonSum+instance Get  DNoSum where get  = getGenericNonSum+    -}
− test/Binrep/LawsSpec.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Binrep.LawsSpec where--import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck.Instances.ByteString()-import Generic.Random-import Test.QuickCheck-import ArbitraryOrphans()--import Binrep-import Binrep.Generic-import Binrep.Type.Int-import Binrep.Type.Common ( Endianness(..) )-import Binrep.Type.ByteString-import Data.Word ( Word8 )-import Data.ByteString qualified as B-import GHC.Generics ( Generic )--import Control.Exception ( evaluate )--spec :: Spec-spec = do-    prop "put is identity on ByteString" $ do-      \(bs :: B.ByteString) -> runPut bs  `shouldBe` bs-    prop "parse-print roundtrip isomorphism (ByteString)" $ do-      \(bs :: B.ByteString) -> runGet (runPut bs) `shouldBe` Right (bs, "")-    prop "parse-print roundtrip isomorphism (generic, sum tag via nullterm constructor)" $ do-      \(d :: D) -> runGet (runPut d) `shouldBe` Right (d, "")-    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)--data D-  = D01Bla     Word8 W1 W8BE-  | D23        W2LE  B.ByteString -- dangerous bytestring, must be last-  | DUnicode例 Word8-  | DSymbols_#-    deriving stock (Generic, Eq, Show)-deriving via (GenericArbitraryU `AndShrinking` D) instance Arbitrary D--dCfg :: Cfg (AsByteString 'C)-dCfg = cfg cSumTagNullTerm--instance BLen D where blen = blenGeneric dCfg-instance Put  D where put  = putGeneric  dCfg-instance Get  D where get  = getGeneric  dCfg--data DNoSum = DNoSum Word8 W1 W2LE W8BE-  | DNoSumBad-    deriving stock (Generic, Eq, Show)-deriving via (GenericArbitraryU `AndShrinking` DNoSum) instance Arbitrary DNoSum--instance BLen DNoSum where blen = blenGeneric cNoSum-instance Put  DNoSum where put  = putGeneric  cNoSum-instance Get  DNoSum where get  = getGeneric  cNoSum
+ test/Binrep/TypesSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module Binrep.TypesSpec where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck.Instances.ByteString()++import Binrep+import Data.ByteString qualified as B++spec :: Spec+spec = do+    prop "put is identity on ByteString" $ do+      \(bs :: B.ByteString) -> runPut bs  `shouldBe` bs+    prop "parse-print roundtrip isomorphism (ByteString)" $ do+      \(bs :: B.ByteString) ->+        runGet (runPut bs) `shouldSatisfy`+          (\case Right (bs', "") -> bs == bs'; _ -> False)