diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2022 Ben Orchard (@raehik) +Copyright (c) 2022-2025 Ben Orchard (@raehik) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Gauge + +import Binrep +import Binrep.Generic +import Binrep.Type.NullTerminated +import Data.ByteString qualified as B +import Refined + +import GHC.Generics ( Generic ) +import Data.Word + +{- +data X = X Word8 Word16 Word8 + deriving stock (Generic) + +instance Put X where put = putGeneric c +instance Put' X where put' = put'Generic +instance BLen X where blen _ = 4 +-} + +data X3 + = X31 Word8 + | X32 Word8 + | X33 Word8 (NullTerminated B.ByteString) X3 + deriving stock (Generic) + +instance BLen X3 where blen = blenGenericSum $ 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 + ] + ] diff --git a/binrep.cabal b/binrep.cabal --- a/binrep.cabal +++ b/binrep.cabal @@ -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 diff --git a/src/Binrep.hs b/src/Binrep.hs --- a/src/Binrep.hs +++ b/src/Binrep.hs @@ -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!) +-} diff --git a/src/Binrep/BLen.hs b/src/Binrep/BLen.hs --- a/src/Binrep/BLen.hs +++ b/src/Binrep/BLen.hs @@ -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 diff --git a/src/Binrep/BLen/Internal/AsBLen.hs b/src/Binrep/BLen/Internal/AsBLen.hs deleted file mode 100644 --- a/src/Binrep/BLen/Internal/AsBLen.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Binrep.BLen.Internal.AsBLen where - -import GHC.Natural ( minusNaturalMaybe ) -import GHC.Num.Natural -import GHC.Exts -import Binrep.Util ( posIntToNat ) - --- | Helper definitions for using the given type to store byte lengths. --- --- Byte lengths must be non-negative. Thus, the ideal representation is a --- 'Natural'. However, most underlying types that we use ('B.ByteString', lists) --- store their length in 'Int's. By similarly storing an 'Int' ourselves, we --- could potentially improve performance. --- --- I like both options, and don't want to give up either. So we provide helpers --- via a typeclass so that the user doesn't ever have to think about the --- underlying type. --- --- For simplicity, documentation may consider 'a' to be an "unsigned" type. For --- example, underflow refers to a negative 'a' result. -class AsBLen a where - -- | Safe blen subtraction, returning 'Nothing' for negative results. - -- - -- Regular subtraction should only be used when you have a guarantee that it - -- won't underflow. - safeBLenSub :: a -> a -> Maybe a - - -- | Convert some 'Int' @i@ where @i >= 0@ to a blen. - -- - -- This is intended for wrapping the output of 'length' functions. - posIntToBLen :: Int -> a - - -- | Convert some 'Word#' @w@ where @w <= maxBound @a@ to a blen. - wordToBLen# :: Word# -> a - - -- | Convert some 'Natural' @n@ where @n <= maxBound @a@ to a blen. - natToBLen :: Natural -> a - -instance AsBLen Int where - safeBLenSub x y = if z >= 0 then Just z else Nothing where z = x - y - {-# INLINE safeBLenSub #-} - - posIntToBLen = id - {-# INLINE posIntToBLen #-} - - natToBLen = \case - NS w# -> wordToBLen# w# - NB _ -> error "TODO natural too large" - {-# INLINE natToBLen #-} - - wordToBLen# w# = I# (word2Int# w#) - {-# INLINE wordToBLen# #-} - -instance AsBLen Natural where - safeBLenSub = minusNaturalMaybe - {-# INLINE safeBLenSub #-} - - posIntToBLen = posIntToNat - {-# INLINE posIntToBLen #-} - - wordToBLen# = NS - {-# INLINE wordToBLen# #-} - - natToBLen = id - {-# INLINE natToBLen #-} diff --git a/src/Binrep/CBLen.hs b/src/Binrep/CBLen.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/CBLen.hs @@ -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 diff --git a/src/Binrep/Common/Class/TypeErrors.hs b/src/Binrep/Common/Class/TypeErrors.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Class/TypeErrors.hs @@ -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" diff --git a/src/Binrep/Common/Via/Generically/NonSum.hs b/src/Binrep/Common/Via/Generically/NonSum.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Via/Generically/NonSum.hs @@ -0,0 +1,3 @@ +module Binrep.Common.Via.Generically.NonSum where + +newtype GenericallyNonSum a = GenericallyNonSum { unGenericallyNonSum :: a } diff --git a/src/Binrep/Common/Via/Prim.hs b/src/Binrep/Common/Via/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Common/Via/Prim.hs @@ -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 } diff --git a/src/Binrep/Example.hs b/src/Binrep/Example.hs deleted file mode 100644 --- a/src/Binrep/Example.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Binrep.Example where - -import Binrep -import Binrep.Generic -import Binrep.Generic qualified as BR -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.Int - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -import Data.Void ( Void ) - -data DV - deriving stock (Generic, Data) - --- Disallowed. No binrepping void datatypes. -{- -instance BLen DV where blen = blenGeneric BR.cNoSum -instance Put DV where put = putGeneric BR.cNoSum -instance Get DV where get = getGeneric BR.cNoSum --} - -data DU = DU - deriving stock (Generic, Data, Show, Eq) - ---instance BLen DU where blen = blenGeneric BR.cNoSum -instance BLen DU where type CBLen DU = CBLenGeneric Void DU -instance Put DU where put = putGeneric cNoSum -instance Get DU where get = getGeneric cNoSum - -data DSS = DSS - { dss1 :: I 'U 'I1 'LE - , dss2 :: I 'U 'I2 'LE - , dss3 :: I 'U 'I4 'LE - , dss4 :: I 'U 'I8 'LE - , dss5 :: I 'U 'I1 'LE - } deriving stock (Generic, Data, Show, Eq) - -instance BLen DSS where blen = blenGeneric cNoSum ---instance BLen DSS where type CBLen DSS = CBLenGeneric Void DSS -instance Put DSS where put = putGeneric cNoSum -instance Get DSS where get = getGeneric cNoSum - -data DCS = DCS1 {- DSS -} | DCS2 | DCS3 | DCS4 | DCS5 - deriving stock (Generic, Data, Show, Eq) - -type BrSumDCS = I 'U 'I1 'LE -brCfgDCS :: BR.Cfg BrSumDCS -brCfgDCS = BR.cfg $ BR.cSumTagHex $ drop 3 - ---instance BLen DCS where blen = BR.blenGeneric brCfgDCS -instance BLen DCS where type CBLen DCS = CBLenGeneric BrSumDCS DCS -instance Put DCS where put = putGeneric brCfgDCS -instance Get DCS where get = getGeneric brCfgDCS - -data DX = DX DU - deriving stock (Generic, Data, Show, Eq) - ---instance BLen DX where blen = blenGeneric brCfgNoSum -instance BLen DX where type CBLen DX = CBLenGeneric Void DX -instance Put DX where put = putGeneric cNoSum -instance Get DX where get = getGeneric cNoSum diff --git a/src/Binrep/Example/FileTable.hs b/src/Binrep/Example/FileTable.hs deleted file mode 100644 --- a/src/Binrep/Example/FileTable.hs +++ /dev/null @@ -1,105 +0,0 @@ -module Binrep.Example.FileTable where - -import Binrep -import Refined hiding ( Weaken ) -import Refined.Unsafe -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.Int -import Binrep.Type.LenPfx -import FlatParse.Basic qualified as FP -import Data.ByteString qualified as B -import Strongweak -import Strongweak.Generic ---import Data.Map ( Map ) -import GHC.Generics ( Generic ) -import GHC.Exts -import Data.Vector.Sized qualified as V -import Data.Word - -type BS = B.ByteString - --- We're unable to put one invariant in the types: an entry can't be placed past --- the maximum offset. Validating that requires quite a lot of work: we have to --- do much of the layouting work, which will be repeated for serializing. This --- is a downside of phase separation, it crops up every now and then. --- --- The BLen instance will similarly be a bit complex, but it could probably be --- implemented with similar code to strengthening. -newtype Table s a = Table { unTable :: SW s (LenPfx 'I1 'LE (Entry s a)) } - -instance (Put a, BLen a) => Put (Table 'Strong a) where put = putFileTable - -putFileTable :: (Put a, BLen a) => Table 'Strong a -> Builder -putFileTable (Table a@(LenPfx es)) = - let es' = V.map prepEntry es - osBase = V.sum $ V.map (\(l, _, _) -> l) es' - in case V.foldl go ((fromIntegral osBase) - 1, mempty, mempty) es' of - (_, bh, bd) -> put (lenPfxSize a) <> bh <> bd - where - go :: (Word8, Builder, Builder) -> (BLenT, Word8 -> Builder, BS) -> (Word8, Builder, Builder) - go (os, bh, bd) (_, eh, ed) = (os+fromIntegral (B.length ed), bh<>eh os, bd<>put ed) - -prepEntry :: (Put a, BLen a) => Entry 'Strong a -> (BLenT, Word8 -> Builder, BS) -prepEntry (Entry nm bs) = (l, b, bs') - where - bs' = unrefine bs - b os = - put nm <> put os <> put (fromIntegral (B.length bs') :: Word8) - l = blen nm + 1 + 1 + blen bs' - -instance Get a => Get (Table 'Strong a) where get = getFileTable - -getFileTable :: Get a => Getter (Table 'Strong a) -getFileTable = FP.withAddr# $ \addr# -> Table <$> getLenPfx (getWith addr#) - -{- -This is certainly a weird type. - - * Can use regular strongweak generics - * Has no 'Get' instance - * Has a 'GetWith Addr#' instance - * Has no 'Put' instance - * Has no 'PutWith' instance - -You can't serialize an 'Entry' by itself, because it serializes to two -artifacts, a header entry and the associated data. Now I see why Kaitai Struct -was having trouble with serializing this sort of type. --} -data Entry s a = Entry - { entryName :: a - , entryData :: SW s (Refined (SizeLessThan (IMax 'U 'I1)) BS) - } deriving stock (Generic) -deriving stock instance Show a => Show (Entry 'Weak a) -deriving stock instance Eq a => Eq (Entry 'Weak a) -deriving stock instance Show a => Show (Entry 'Strong a) -deriving stock instance Eq a => Eq (Entry 'Strong a) -instance Weaken (Entry 'Strong a) where - type Weak (Entry 'Strong a) = Entry 'Weak a - weaken = weakenGeneric -instance Strengthen (Entry 'Strong a) where - strengthen = strengthenGeneric - -instance Get a => GetWith Addr# (Entry 'Strong a) where getWith = getEntry - -getEntry :: Get a => Addr# -> Getter (Entry 'Strong a) -getEntry addr# = do - name <- get - dat <- FP.withAnyWord8# $ \offset# -> FP.withAnyWord8# $ \len# -> - FP.takeBsOffAddr# addr# (w8i# offset#) (w8i# len#) - return $ Entry name (reallyUnsafeRefine dat) - -w8i# :: Word8# -> Int# -w8i# w# = word2Int# (word8ToWord# w#) - -exBs :: BS -exBs = B.pack - [ 0x02 - , 0x30, 0x31, 0x32, 0x00 - , 12 -- <- offset!! - , 0x01 - , 0x39, 0x38, 0x00 - , 13 - , 0x01 - , 0xFF - , 0xF0 - ] diff --git a/src/Binrep/Example/Sum.hs b/src/Binrep/Example/Sum.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/Sum.hs @@ -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" diff --git a/src/Binrep/Example/Tar.hs b/src/Binrep/Example/Tar.hs deleted file mode 100644 --- a/src/Binrep/Example/Tar.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Binrep.Example.Tar where - -import Binrep -import Binrep.Generic -import Binrep.Type.NullPadded -import Binrep.Type.AsciiNat - -import GHC.Generics ( Generic ) - -import Data.Word ( Word8 ) - -import GHC.TypeNats - -import Data.ByteString qualified as B - -import FlatParse.Basic qualified as FP - -type BS = B.ByteString - --- | The naturals in tars are sized octal ASCII digit strings that end with a --- null byte (and may start with leading ASCII zeroes). The size includes the --- terminating null, so you get @n-1@ digits. What a farce. --- --- Don't use this constructor directly! The size must be checked to ensure it --- fits. -newtype TarNat n = TarNat { getTarNat :: AsciiNat 8 } - deriving stock (Generic, Show, Eq) - -instance KnownNat n => BLen (TarNat n) where - type CBLen (TarNat n) = n - --- | No need to check for underflow etc. as TarNat guarantees good sizing. -instance KnownNat n => Put (TarNat n) where - put (TarNat an) = put pfxNulls <> put an <> put @Word8 0x00 - where - pfxNulls = B.replicate (fromIntegral pfxNullCount) 0x30 - pfxNullCount = n - blen an - 1 - n = typeNatToBLen @n - -instance KnownNat n => Get (TarNat n) where - get = do - an <- FP.isolate (fromIntegral (n - 1)) get - get @Word8 >>= \case - 0x00 -> return $ TarNat an - w -> eBase $ EExpectedByte 0x00 w - where - n = typeNatToBLen @n - --- Partial header -data Tar = Tar - { tarFileName :: NullPadded 100 BS - , tarFileMode :: TarNat 8 - , tarFileUIDOwner :: TarNat 8 - , tarFileUIDGroup :: TarNat 8 - , tarFileFileSize :: TarNat 12 - , tarFileLastMod :: TarNat 12 - } deriving stock (Generic, Show, Eq) - -instance BLen Tar where blen = blenGeneric cNoSum -instance Put Tar where put = putGeneric cNoSum -instance Get Tar where get = getGeneric cNoSum diff --git a/src/Binrep/Example/Tga.hs b/src/Binrep/Example/Tga.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Example/Tga.hs @@ -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 + +-} diff --git a/src/Binrep/Example/Tiff.hs b/src/Binrep/Example/Tiff.hs deleted file mode 100644 --- a/src/Binrep/Example/Tiff.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} - -module Binrep.Example.Tiff where - -import Binrep -import Binrep.Generic -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.Int -import Binrep.Type.Magic -import Binrep.Type.Byte -import FlatParse.Basic ( (<|>) ) - -import GHC.Generics ( Generic ) -import Data.Data ( Data, Typeable ) -import GHC.TypeLits - -import Data.ByteString qualified as B - -type W8 = I 'U 'I1 'LE - -data Tiff where - Tiff :: (Put (I 'U 'I4 end), bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, KnownNat (Length bs)) => TiffBody end -> Tiff - -instance Show Tiff where - show (Tiff body) = "Tiff " <> show body - -data TiffBody (end :: Endianness) = TiffBody - { tiffBodyMagic :: Magic (TiffMagic end) - , tiffBodyExInt :: I 'U 'I4 end - } deriving stock (Generic, Show, Eq) -deriving stock instance (KnownSymbol (TiffMagic end), Typeable end) => Data (TiffBody end) - -instance (bs ~ MagicBytes (TiffMagic end), KnownNat (Length bs)) => BLen (TiffBody end) where - blen = blenGeneric cNoSum -instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Put irep) => Put (TiffBody end) where - put = putGeneric cNoSum -instance (bs ~ MagicBytes (TiffMagic end), ReifyBytes bs, irep ~ I 'U 'I4 end, Get irep) => Get (TiffBody end) where - get = getGeneric cNoSum - -instance BLen Tiff where - blen (Tiff body) = blen body - -instance Put Tiff where - put (Tiff body) = put body - -instance Get Tiff where - get = fmap Tiff (get @(TiffBody 'LE)) <|> fmap Tiff (get @(TiffBody 'BE)) - -type family TiffMagic (end :: Endianness) :: Symbol where - TiffMagic 'LE = "II" - TiffMagic 'BE = "MM" - -tiffLEbs :: B.ByteString -tiffLEbs = B.pack [0x49, 0x49, 0xFF, 0x00, 0x00, 0x00] - -tiffBEbs :: B.ByteString -tiffBEbs = B.pack [0x4D, 0x4D, 0x00, 0x00, 0x00, 0xFF] diff --git a/src/Binrep/Example/Wav.hs b/src/Binrep/Example/Wav.hs deleted file mode 100644 --- a/src/Binrep/Example/Wav.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Binrep.Example.Wav where - -import Binrep -import Binrep.Generic -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.Int -import Binrep.Type.Magic - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -type End = 'LE -type W32 = I 'U 'I4 End -type W16 = I 'U 'I2 End - -data WavHeader = WavHeader - { wavHeaderMagic :: Magic "RIFF" - , wavHeaderChunkSize :: W32 -- file size - 8 - , wavHeaderFmt :: Magic "WAVE" - , wavHeaderFmtChunkMarker :: Magic "fmt " - , wavHeaderFmtType :: W16 - , wavHeaderChannels :: W16 - } deriving stock (Generic, Data, Show, Eq) - -instance BLen WavHeader where blen = blenGeneric cNoSum -instance Put WavHeader where put = putGeneric cNoSum -instance Get WavHeader where get = getGeneric cNoSum diff --git a/src/Binrep/Extra/HexByteString.hs b/src/Binrep/Extra/HexByteString.hs deleted file mode 100644 --- a/src/Binrep/Extra/HexByteString.hs +++ /dev/null @@ -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 diff --git a/src/Binrep/Generic.hs b/src/Binrep/Generic.hs --- a/src/Binrep/Generic.hs +++ b/src/Binrep/Generic.hs @@ -1,79 +1,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 diff --git a/src/Binrep/Generic/BLen.hs b/src/Binrep/Generic/BLen.hs deleted file mode 100644 --- a/src/Binrep/Generic/BLen.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( - -module Binrep.Generic.BLen where - -import GHC.Generics -import GHC.TypeLits ( TypeError ) - -import Binrep.BLen -import Binrep.Generic.Internal -import Util.Generic - -blenGeneric :: (Generic a, GBLen (Rep a), BLen w) => Cfg w -> a -> BLenT -blenGeneric cfg = gblen cfg . from - -class GBLen f where - gblen :: BLen w => Cfg w -> f p -> BLenT - --- | Empty constructor. -instance GBLen U1 where - gblen _ U1 = 0 - --- | Field. -instance BLen c => GBLen (K1 i c) where - gblen _ (K1 c) = blen c - --- | Product type fields are consecutive. -instance (GBLen l, GBLen r) => GBLen (l :*: r) where - gblen cfg (l :*: r) = gblen cfg l + gblen cfg r - --- | Constructor sums are differentiated by a prefix tag. -instance GBLenSum (l :+: r) => GBLen (l :+: r) where - gblen = gblensum - --- | Refuse to derive instance for void datatype. -instance TypeError GErrRefuseVoid => GBLen V1 where - gblen = undefined - --- | Any datatype, constructor or record. -instance GBLen f => GBLen (M1 i d f) where - gblen cfg = gblen cfg . unM1 - --------------------------------------------------------------------------------- - -class GBLenSum f where - gblensum :: BLen w => Cfg w -> f p -> BLenT - -instance (GBLenSum l, GBLenSum r) => GBLenSum (l :+: r) where - gblensum cfg = \case L1 l -> gblensum cfg l - R1 r -> gblensum cfg r - -instance (GBLen f, Constructor c) => GBLenSum (C1 c f) where - gblensum cfg x = blen ((cSumTag cfg) (conName' @c)) + gblen cfg (unM1 x) diff --git a/src/Binrep/Generic/CBLen.hs b/src/Binrep/Generic/CBLen.hs deleted file mode 100644 --- a/src/Binrep/Generic/CBLen.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -{- | _Experimental._ Generically derive 'CBLen' type family instances. - -A type having a valid 'CBLen' instance usually indicates one of the following: - - * it's a primitive, or extremely simple - * it holds size information in its type - * it's constructed from other constant byte length types - -The first two cases must be handled manually. The third case is where Haskell -generics excel, and the one this module targets. - -You can (attempt to) derive a 'CBLen' type family instance generically for a -type via - - instance BLen a where type CBLen a = CBLenGeneric w a - -As with deriving @BLen@ generically, you must provide the type used to store the -sum tag for sum types. - -Then try using it. Hopefully it works, or you get a useful type error. If not, -sorry. I don't have much faith in this code. --} - -module Binrep.Generic.CBLen where - -import Binrep.BLen -import Binrep.Generic.Internal - -import GHC.Generics -import GHC.TypeLits -import Data.Kind - -import Data.Type.Equality -import Data.Type.Bool - -type CBLenGeneric w a = GCBLen w (Rep a) - -type family GCBLen w (f :: k -> Type) :: Natural where - GCBLen _ U1 = 0 - GCBLen _ (K1 i c) = CBLen c - GCBLen w (l :*: r) = GCBLen w l + GCBLen w r - - GCBLen w (l :+: r) = CBLen w + GCBLenCaseMaybe (GCBLenSum w (l :+: r)) - - GCBLen _ V1 = TypeError GErrRefuseVoid - GCBLen w (M1 _ _ f) = GCBLen w f - ---type family GCBLenSum w (f :: k -> Type) :: Maybe Natural where -type family GCBLenSum w (f :: k -> Type) where - GCBLenSum w (C1 ('MetaCons name _ _) f) = JustX (GCBLen w f) name - GCBLenSum w (l :+: r) = MaybeEq (GCBLenSum w l) (GCBLenSum w r) - -type family MaybeEq a b where - MaybeEq (JustX n nName) (JustX m _) = If (n == m) (JustX n nName) NothingX - MaybeEq _ _ = NothingX - --- | I don't know how to pattern match in types without writing type families. -type family GCBLenCaseMaybe a where - GCBLenCaseMaybe (JustX n _) = n - GCBLenCaseMaybe NothingX = - TypeError - ( 'Text "Two constructors didn't have equal constant size." - ':$$: 'Text "Sry dunno how to thread errors thru LOL" - ) - --- TODO rewrite this stuff to thread error info through! -data JustX a b -data NothingX diff --git a/src/Binrep/Generic/Get.hs b/src/Binrep/Generic/Get.hs deleted file mode 100644 --- a/src/Binrep/Generic/Get.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( - -module Binrep.Generic.Get where - -import GHC.Generics -import GHC.TypeLits ( TypeError ) - -import Binrep.Get -import Binrep.Generic.Internal -import Util.Generic - -import FlatParse.Basic qualified as FP -import Control.Applicative ( (<|>) ) - -import Numeric.Natural - -getGeneric :: (Generic a, GGetD (Rep a), Get w) => Cfg w -> Getter a -getGeneric cfg = to <$> ggetD cfg - -class GGetD f where - ggetD :: Get w => Cfg w -> Getter (f a) - -instance (GGetC f, Datatype d) => GGetD (D1 d f) where - ggetD cfg = M1 <$> ggetC cfg (datatypeName' @d) - -class GGetC f where - ggetC :: Get w => Cfg w -> String -> Getter (f a) - --- | Refuse to derive instance for empty data types. -instance TypeError GErrRefuseVoid => GGetC V1 where - ggetC = undefined - --- | TODO: Non-sum data types. -instance (GGetS f, Constructor c) => GGetC (C1 c f) where - ggetC cfg dStr = (M1 . snd) <$> ggetS cfg dStr (conName' @c) 0 - -class GGetS f where - ggetS :: Get w => Cfg w -> String -> String -> Natural -> Getter (Natural, (f a)) - --- | The empty constructor trivially succeeds without parsing anything. -instance GGetS U1 where - ggetS _ _ _ fIdx = pure (fIdx, U1) - -instance (GGetS l, GGetS r) => GGetS (l :*: r) where - ggetS cfg dStr cStr fIdx = do - (fIdx', l) <- ggetS cfg dStr cStr fIdx - (fIdx'', r) <- ggetS cfg dStr cStr (fIdx'+1) - pure (fIdx'', l :*: r) - -instance (Get a, Selector s) => GGetS (S1 s (Rec0 a)) where - ggetS _ dStr cStr fIdx = do - a <- getEWrap $ EGeneric dStr . EGenericField cStr sStr fIdx - pure (fIdx, M1 (K1 a)) - where - sStr = selName'' @s - --------------------------------------------------------------------------------- - --- | Constructor sums are differentiated by a prefix tag. -instance GGetCSum (l :+: r) => GGetC (l :+: r) where - ggetC cfg dStr = do - tag <- getEWrap $ EGeneric dStr . EGenericSum . EGenericSumTag - case ggetCSum cfg dStr tag of - Just parser -> parser - Nothing -> do - let tagPretty = cSumTagShow cfg $ tag - FP.err $ EGeneric dStr $ EGenericSum $ EGenericSumTagNoMatch [] tagPretty - --- | TODO: Want to return an @Either [(String, Text)]@ indicating the --- constructors and their expected tags tested, but needs fiddling (can't use --- 'Alternative'). Pretty minor, but Aeson does it and it's nice. -class GGetCSum f where - ggetCSum :: Get w => Cfg w -> String -> w -> Maybe (Getter (f a)) - -instance (GGetCSum l, GGetCSum r) => GGetCSum (l :+: r) where - ggetCSum cfg dStr tag = l <|> r - where - l = fmap L1 <$> ggetCSum cfg dStr tag - r = fmap R1 <$> ggetCSum cfg dStr tag - -instance (GGetS f, Constructor c) => GGetCSum (C1 c f) where - ggetCSum cfg dStr tag = - let cStr = conName' @c - cTag = (cSumTag cfg) cStr - in if (cSumTagEq cfg) tag cTag - then Just ((M1 . snd) <$> ggetS cfg dStr cStr 0) - else Nothing diff --git a/src/Binrep/Generic/Internal.hs b/src/Binrep/Generic/Internal.hs deleted file mode 100644 --- a/src/Binrep/Generic/Internal.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Binrep.Generic.Internal where - -import GHC.TypeLits -import Data.Text ( Text ) - -data Cfg a = Cfg - { cSumTag :: String -> a - -- ^ How to turn a constructor name into a byte tag. - - , cSumTagEq :: a -> a -> Bool - , cSumTagShow :: a -> Text - } - --- | Common type error string for when GHC attempts to derive an binrep instance --- for a (the?) void datatype @V1@. -type GErrRefuseVoid = - 'Text "Refusing to derive binary representation for void datatype" diff --git a/src/Binrep/Generic/Put.hs b/src/Binrep/Generic/Put.hs deleted file mode 100644 --- a/src/Binrep/Generic/Put.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -- required for TypeError >:( - -module Binrep.Generic.Put where - -import GHC.Generics -import GHC.TypeLits ( TypeError ) - -import Binrep.Put -import Binrep.Generic.Internal -import Util.Generic - -putGeneric :: (Generic a, GPut (Rep a), Put w) => Cfg w -> a -> Builder -putGeneric cfg = gput cfg . from - -class GPut f where - gput :: Put w => Cfg w -> f p -> Builder - --- | Empty constructor. -instance GPut U1 where - gput _ U1 = mempty - --- | Field. -instance Put c => GPut (K1 i c) where - gput _ = put . unK1 - --- | Product type fields are consecutive. -instance (GPut l, GPut r) => GPut (l :*: r) where - gput cfg (l :*: r) = gput cfg l <> gput cfg r - --- | Constructor sums are differentiated by a prefix tag. -instance (GPutSum (l :+: r), GetConName (l :+: r)) => GPut (l :+: r) where - gput = gputsum - --- | Refuse to derive instance for void datatype. -instance TypeError GErrRefuseVoid => GPut V1 where - gput = undefined - --- | Any datatype, constructor or record. -instance GPut f => GPut (M1 i d f) where - gput cfg = gput cfg . unM1 - --------------------------------------------------------------------------------- - -class GPutSum f where - gputsum :: Put w => Cfg w -> f a -> Builder - -instance (GPutSum l, GPutSum r) => GPutSum (l :+: r) where - gputsum cfg = \case L1 a -> gputsum cfg a - R1 a -> gputsum cfg a - -instance (GPut r, Constructor c) => GPutSum (C1 c r) where - gputsum cfg x = putTag <> putConstructor - where putTag = put $ (cSumTag cfg) (conName' @c) - putConstructor = gput cfg $ unM1 x - ---- - --- | Get the name of the constructor of a sum datatype. -class GetConName f where - getConName :: f a -> String - -instance (GetConName a, GetConName b) => GetConName (a :+: b) where - getConName (L1 x) = getConName x - getConName (R1 x) = getConName x - -instance Constructor c => GetConName (C1 c a) where - getConName = conName diff --git a/src/Binrep/Get.hs b/src/Binrep/Get.hs --- a/src/Binrep/Get.hs +++ b/src/Binrep/Get.hs @@ -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 + +-} diff --git a/src/Binrep/Get/Error.hs b/src/Binrep/Get/Error.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Get/Error.hs @@ -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) ] diff --git a/src/Binrep/Get/Struct.hs b/src/Binrep/Get/Struct.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Get/Struct.hs @@ -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) diff --git a/src/Binrep/Put.hs b/src/Binrep/Put.hs --- a/src/Binrep/Put.hs +++ b/src/Binrep/Put.hs @@ -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 diff --git a/src/Binrep/Put/Struct.hs b/src/Binrep/Put/Struct.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Put/Struct.hs @@ -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) diff --git a/src/Binrep/Type/AsciiNat.hs b/src/Binrep/Type/AsciiNat.hs --- a/src/Binrep/Type/AsciiNat.hs +++ b/src/Binrep/Type/AsciiNat.hs @@ -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) + +-} diff --git a/src/Binrep/Type/Byte.hs b/src/Binrep/Type/Byte.hs deleted file mode 100644 --- a/src/Binrep/Type/Byte.hs +++ /dev/null @@ -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# diff --git a/src/Binrep/Type/ByteString.hs b/src/Binrep/Type/ByteString.hs deleted file mode 100644 --- a/src/Binrep/Type/ByteString.hs +++ /dev/null @@ -1,100 +0,0 @@ -{- | Machine bytestrings. - -I mix string and bytestring terminology here due to bad C influences, but this -module is specifically interested in bytestrings and their encoding. String/text -encoding is handled in another module. - -Note that the length prefix predicate is also defined here... because that's -just Pascal-style bytestrings, extended to other types. I can't easily put it in -an orphan module, because we define byte length for *all length-prefixed types* -in one fell swoop. --} - --- TODO redocument. pretty all over the place - -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} - -module Binrep.Type.ByteString where - -import Binrep -import Binrep.Type.Common ( Endianness ) -import Binrep.Type.Int -import Binrep.Util - -import Refined -import Refined.Unsafe - -import Data.ByteString qualified as B -import FlatParse.Basic qualified as FP -import Data.Word ( Word8 ) -import GHC.TypeNats ( KnownNat ) - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -import Data.Typeable ( Typeable, typeRep ) - --- | Bytestring representation. -data Rep - = C - -- ^ C-style bytestring. Arbitrary length, terminated with a null byte. - -- Permits no null bytes inside the bytestring. - - | Pascal ISize Endianness - -- ^ Pascal-style bytestring. Length defined in a prefixing integer of given - -- size and endianness. - deriving stock (Generic, Data, Show, Eq) - --- | A bytestring using the given representation, stored in the 'Text' type. -type AsByteString (rep :: Rep) = Refined rep B.ByteString - -getCString :: Getter B.ByteString -getCString = FP.cut FP.anyCString $ EBase $ EFailNamed "cstring" - -instance BLen (AsByteString 'C) where - blen cbs = posIntToBLen $ B.length (unrefine cbs) + 1 - -instance Put (AsByteString 'C) where - put = putCString . unrefine - -putCString :: B.ByteString -> Builder -putCString bs = put bs <> put @Word8 0x00 - -instance Get (AsByteString 'C) where - get = reallyUnsafeRefine <$> getCString - -instance (itype ~ I 'U size end, irep ~ IRep 'U size, KnownNat (CBLen irep)) => BLen (AsByteString ('Pascal size end)) where - blen pbs = cblen @itype + blen (unrefine pbs) - -instance (itype ~ I 'U size end, irep ~ IRep 'U size, Put itype, Num irep) => Put (AsByteString ('Pascal size end)) where - put pbs = put @itype (fromIntegral (B.length bs)) <> put bs - where bs = unrefine pbs - -instance (itype ~ I 'U size end, irep ~ IRep 'U size, Integral irep, Get itype) => Get (AsByteString ('Pascal size end)) where - get = do - len <- get @itype - bs <- FP.takeBs $ fromIntegral len - return $ reallyUnsafeRefine bs - --- | A C-style bytestring must not contain any null bytes. -instance Predicate 'C B.ByteString where - validate p bs - | B.any (== 0x00) bs = throwRefineOtherException (typeRep p) $ - "null byte not permitted in in C-style bytestring" - | otherwise = success - -instance - ( irep ~ IRep 'U size - , Bounded irep, Integral irep - , Show irep, Typeable size, Typeable e - ) => Predicate ('Pascal size e) B.ByteString where - validate p bs - | len > fromIntegral max' - = throwRefineOtherException (typeRep p) $ - "bytestring too long for given length prefix type: " - <>tshow len<>" > "<>tshow max' - | otherwise = success - where - len = B.length bs - max' = maxBound @irep diff --git a/src/Binrep/Type/Common.hs b/src/Binrep/Type/Common.hs deleted file mode 100644 --- a/src/Binrep/Type/Common.hs +++ /dev/null @@ -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) diff --git a/src/Binrep/Type/Derived/NullTermPadded.hs b/src/Binrep/Type/Derived/NullTermPadded.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Derived/NullTermPadded.hs @@ -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) diff --git a/src/Binrep/Type/Int.hs b/src/Binrep/Type/Int.hs deleted file mode 100644 --- a/src/Binrep/Type/Int.hs +++ /dev/null @@ -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 diff --git a/src/Binrep/Type/LenPfx.hs b/src/Binrep/Type/LenPfx.hs deleted file mode 100644 --- a/src/Binrep/Type/LenPfx.hs +++ /dev/null @@ -1,110 +0,0 @@ --- TODO cleanup proxy usage (can we be faster via unboxed @Proxy#@ s ?) - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} - -module Binrep.Type.LenPfx where - -import Binrep -import Strongweak -import Data.Either.Validation -import Binrep.Type.Vector ( getVector ) -import Binrep.Type.Common ( Endianness ) -import Binrep.Type.Int -import Binrep.Util ( natVal'' ) -import Data.Vector.Sized ( Vector ) -import Data.Vector.Sized qualified as V -import GHC.TypeNats -import GHC.TypeLits ( OrderingI(..) ) -import Data.Proxy ( Proxy(..) ) - -import GHC.Generics -import Data.Typeable ( Typeable ) - --- | Holy shit - no need to do a smart constructor, it's simply impossible to --- instantiate invalid values of this type! -data LenPfx (size :: ISize) (end :: Endianness) a = - forall n. (KnownNat n, n <= IMax 'U size) => LenPfx { unLenPfx :: Vector n a } - --- uhhhhhhhhhh i dunno. TODO -instance Generic (LenPfx size end a) where - type Rep (LenPfx size end a) = Rec0 (LenPfx size end a) - from = K1 - to = unK1 - -instance Eq a => Eq (LenPfx size end a) where - (LenPfx a) == (LenPfx b) = vsEq a b - --- TODO -instance Show a => Show (LenPfx size end a) where - show (LenPfx a) = "LenPfx ("<>show a<>")" - -vsEq :: forall a n m. (Eq a, KnownNat n, KnownNat m) => Vector n a -> Vector m a -> Bool -vsEq vn vm = - if natVal'' @n == natVal'' @m - then V.toList vn == V.toList vm - else False - -instance Weaken (LenPfx size end a) where - type Weak (LenPfx size end a) = [a] - weaken (LenPfx v) = V.toList v - -instance (KnownNat (MaxBound (IRep 'U size)), Show a, Typeable a, Typeable size, Typeable end) - => Strengthen (LenPfx size end a) where - strengthen l = case lenPfxFromList l of - Nothing -> strengthenFailBase l "TODO doesn't fit" - Just v -> Success v - -asLenPfx - :: forall size end n a irep - . (irep ~ IRep 'U size, KnownNat n, KnownNat (MaxBound irep)) - => Vector n a -> Maybe (LenPfx size end a) -asLenPfx v = - case cmpNat (Proxy :: Proxy n) (Proxy :: Proxy (MaxBound (IRep 'U size))) of - LTI -> Just $ LenPfx v - EQI -> Just $ LenPfx v - GTI -> Nothing - -lenPfxFromList - :: forall size end a irep - . (irep ~ IRep 'U size, KnownNat (MaxBound irep)) - => [a] -> Maybe (LenPfx size end a) -lenPfxFromList l = V.withSizedList l asLenPfx - -instance (BLen a, itype ~ I 'U size end, KnownNat (CBLen itype)) - => BLen (LenPfx size end a) where - blen (LenPfx v) = cblen @itype + blen v - -instance (itype ~ I 'U size end, irep ~ IRep 'U size, Put a, Put itype, Num irep) - => Put (LenPfx size end a) where - put (LenPfx v) = put @itype (fromIntegral (vnatVal v)) <> put v - where - vnatVal :: forall n x. KnownNat n => Vector n x -> Natural - vnatVal _ = natVal'' @n - -lenPfxSize :: Num (IRep 'U size) => LenPfx size end a -> I 'U size end -lenPfxSize (LenPfx v) = fromIntegral (vnatVal v) - where - vnatVal :: forall n x. KnownNat n => Vector n x -> Natural - vnatVal _ = natVal'' @n - -instance (itype ~ I 'U size end, irep ~ IRep 'U size, Get itype, Integral irep, Get a, KnownNat (MaxBound irep)) - => Get (LenPfx size end a) where - get = getLenPfx get - -getLenPfx - :: forall size end a itype irep - . (itype ~ I 'U size end, irep ~ IRep 'U size, Get itype, Integral irep, KnownNat (MaxBound irep)) - => Getter a -> Getter (LenPfx size end a) -getLenPfx g = do - len <- get @itype - case someNatVal (fromIntegral len) of - SomeNat (Proxy :: Proxy n) -> do - x <- getVector @n g - -- TODO we actually know that @n <= MaxBound irep@ before doing this - -- because @len <= maxBound (_ :: irep)@ but that's hard to prove to - -- GHC without lots of refactoring. This is good enough. - case cmpNat (Proxy :: Proxy n) (Proxy :: Proxy (MaxBound irep)) of - GTI -> error "impossible" - LTI -> return $ LenPfx x - EQI -> return $ LenPfx x diff --git a/src/Binrep/Type/Magic.hs b/src/Binrep/Type/Magic.hs --- a/src/Binrep/Type/Magic.hs +++ b/src/Binrep/Type/Magic.hs @@ -1,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 diff --git a/src/Binrep/Type/Magic/UTF8.hs b/src/Binrep/Type/Magic/UTF8.hs deleted file mode 100644 --- a/src/Binrep/Type/Magic/UTF8.hs +++ /dev/null @@ -1,47 +0,0 @@ -{- | Inefficient attempt at UTF-8 magics. - -To encode UTF-8 strings to bytestrings at compile time, we really need more -support from the compiler. We can go @Char -> Natural@, but we can't go @Natural --> [Natural]@ where each value is @<= 255@. Doing so is hard without bit -twiddling. - -The best we can do is get reify the 'Symbol' directly, then encode as UTF-8 at -runtime. It's a bit of a farce, and we can't derive a 'CBLen' instance, but -works just fine. Actually, I dunno, it might be faster than the bytewise magic -handling, depending on how GHC optimizes its instances. --} - -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Binrep.Type.Magic.UTF8 where - -import Binrep - -import GHC.TypeLits -import GHC.Exts ( proxy#, Proxy# ) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text -import Data.ByteString qualified as B -import FlatParse.Basic qualified as FP - -data MagicUTF8 (str :: Symbol) = MagicUTF8 deriving Show - -symVal :: forall str. KnownSymbol str => String -symVal = symbolVal' (proxy# :: Proxy# str) - -instance KnownSymbol str => BLen (MagicUTF8 str) where - blen MagicUTF8 = posIntToBLen $ B.length $ encodeStringUtf8 $ symVal @str - -instance KnownSymbol str => Put (MagicUTF8 str) where - put MagicUTF8 = put $ encodeStringUtf8 $ symVal @str - -instance KnownSymbol str => Get (MagicUTF8 str) where - get = do - let expected = encodeStringUtf8 $ symVal @str - actual <- FP.takeBs $ B.length expected - if actual == expected - then return MagicUTF8 - else eBase $ EExpected expected actual - -encodeStringUtf8 :: String -> B.ByteString -encodeStringUtf8 = Text.encodeUtf8 . Text.pack diff --git a/src/Binrep/Type/NullPadded.hs b/src/Binrep/Type/NullPadded.hs --- a/src/Binrep/Type/NullPadded.hs +++ b/src/Binrep/Type/NullPadded.hs @@ -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 diff --git a/src/Binrep/Type/NullTerminated.hs b/src/Binrep/Type/NullTerminated.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/NullTerminated.hs @@ -0,0 +1,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 +-} diff --git a/src/Binrep/Type/Prefix/Count.hs b/src/Binrep/Type/Prefix/Count.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix/Count.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Prefix/Internal.hs b/src/Binrep/Type/Prefix/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix/Internal.hs @@ -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? diff --git a/src/Binrep/Type/Prefix/Size.hs b/src/Binrep/Type/Prefix/Size.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Prefix/Size.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Sized.hs b/src/Binrep/Type/Sized.hs --- a/src/Binrep/Type/Sized.hs +++ b/src/Binrep/Type/Sized.hs @@ -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 diff --git a/src/Binrep/Type/Text.hs b/src/Binrep/Type/Text.hs --- a/src/Binrep/Type/Text.hs +++ b/src/Binrep/Type/Text.hs @@ -1,193 +1,53 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} +{- TODO 2023-02-15 raehik +Encoding shouldn't change to a bytestring, for efficiency. Due to convenient +representations, we can efficiently serialize a Text directly to a builder, +skipping intermediate ByteString conversion. +Hm. Maybe that means it should be changed to the builder. What does that mean +for decoding? +-} + module Binrep.Type.Text - ( Encoding(..) - , AsText - , Encode, encode + ( AsText + , Encode(..), encode, encodeToRep , Decode(..) - , encodeToRep -#ifdef HAVE_ICU - , decodeViaTextICU -#endif - ) where -import Binrep.Type.Common ( Endianness(..) ) -import Binrep.Type.ByteString ( Rep ) - -import Refined -import Refined.Unsafe - -import Data.ByteString qualified as B -import Data.Text qualified as Text -import Data.Text ( Text ) -import Data.Char qualified as Char -import Data.Text.Encoding qualified as Text -import Data.Either.Combinators qualified as Either - -import GHC.Generics ( Generic ) -import Data.Data ( Data ) - -import Data.Typeable ( Typeable, typeRep ) - -import System.IO.Unsafe qualified -import Control.Exception qualified -import Data.Text.Encoding.Error qualified - -#ifdef HAVE_ICU -import Data.Text.ICU.Convert qualified as ICU -#endif - -type Bytes = B.ByteString - --- | Character encoding. --- --- Byte-oriented encodings like ASCII and UTF-8 don't need to worry about --- endianness. For UTF-16 and UTF-32, the designers decided to allow different --- endiannesses, rather than saying "codepoints must be X-endian". -data Encoding - = UTF8 - | UTF16 Endianness - | UTF32 Endianness - | ASCII -- ^ 7-bit - | SJIS - deriving stock (Generic, Data, Show, Eq) - --- | A string of a given encoding, stored in the 'Text' type. -type AsText (enc :: Encoding) = Refined enc Text + , module Binrep.Type.Text.Encoding.Utf8 + , module Binrep.Type.Text.Encoding.Ascii + , module Binrep.Type.Text.Encoding.Utf16 + , module Binrep.Type.Text.Encoding.Utf32 + , module Binrep.Type.Text.Encoding.ShiftJis --- | Bytestring encoders for text validated for a given encoding. -class Encode (enc :: Encoding) where - -- | Encode text to bytes. Internal function, use 'encode'. - encode' :: Text -> Bytes + ) where -instance Encode 'UTF8 where encode' = Text.encodeUtf8 +import Binrep.Type.Text.Internal --- | ASCII is a subset of UTF-8, so valid ASCII is valid UTF-8, so this is safe. -instance Encode 'ASCII where encode' = encode' @'UTF8 +import 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 diff --git a/src/Binrep/Type/Text/Encoding/Ascii.hs b/src/Binrep/Type/Text/Encoding/Ascii.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Ascii.hs @@ -0,0 +1,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" diff --git a/src/Binrep/Type/Text/Encoding/ShiftJis.hs b/src/Binrep/Type/Text/Encoding/ShiftJis.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/ShiftJis.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Text/Encoding/Utf16.hs b/src/Binrep/Type/Text/Encoding/Utf16.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf16.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Text/Encoding/Utf32.hs b/src/Binrep/Type/Text/Encoding/Utf32.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf32.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Text/Encoding/Utf8.hs b/src/Binrep/Type/Text/Encoding/Utf8.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Encoding/Utf8.hs @@ -0,0 +1,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' diff --git a/src/Binrep/Type/Text/Internal.hs b/src/Binrep/Type/Text/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Text/Internal.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Thin.hs b/src/Binrep/Type/Thin.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Type/Thin.hs @@ -0,0 +1,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 diff --git a/src/Binrep/Type/Varint.hs b/src/Binrep/Type/Varint.hs deleted file mode 100644 --- a/src/Binrep/Type/Varint.hs +++ /dev/null @@ -1,136 +0,0 @@ -{- | Variable-length integers (varints), a method to store arbitrarily large - integers in a space efficient manner. - -Note that varints aren't particularly efficient due to their decoding being -slow. They are most interesting when you wish to provide support for large -integers, but know that many (most?) inputs will be small, and want to be space -efficient for them. Protocol Buffers uses them extensively, while Cap'n Proto -swears them off. - -TODO - - * https://en.wikipedia.org/wiki/Variable-length_quantity - * I've defined basic unsigned varints. Signed varints have lots of options. - You can use twos comp, zigzag, a sign bit, whatever. --} - -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Binrep.Type.Varint where - -import Binrep -import Binrep.Type.Common ( Endianness(..) ) - -import Data.Bits -import FlatParse.Basic qualified as FP - -import Data.Word ( Word8 ) - --- | A variable-length unsigned integer (natural). --- --- The base algorithm is to split the natural into groups of 7 bits, and use the --- MSB to indicate whether another octet follows. You must specify a handful of --- type variables, which select precise varint behaviour beyond this. See their --- documentation for details. --- --- You may select the type to use varnats at, but error handling isn't provided: --- negatives won't work correctly, and overflow cannot be detected. So most of --- the time, you probably want 'Natural' and 'Integer'. --- --- Some examples: --- --- * @'Varnat' ''Redundant' ''OnContinues' ''BE' matches VLQ. --- * @'Varnat' ''Redundant' ''OnContinues' ''LE' matches LEB128, protobuf. --- * @'Varnat' ''Bijective' ''OnContinues' ''LE' matches Git's varints. --- * @'Varnat' ''Bijective' ''OffContinues' ''LE' matches BPS's varints. -newtype Varnat (enc :: Encoding) (cont :: ContinuationBitBehaviour) (e :: Endianness) i = Varnat { getVarnat :: i } - deriving (Eq, Ord, Enum, Num, Real, Integral) via i - deriving stock Show - -data ContinuationBitBehaviour - = OnContinues - -- ^ on=continue, off=end - - | OffContinues - -- ^ on=end, off=continue - -data Encoding - = Redundant - -- ^ simple, some varints have the same value - - | Bijective - -- ^ each integer has exactly 1 varint encoding - --- | VLQ (cont=on) -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'BE i) where - get = go (0 :: i) - where - go i = do - w8 <- FP.anyWord8 - let i' = unsafeShiftL i 7 .|. fromIntegral (clearBit w8 7) - if testVarintCont @cont w8 7 then go i' else pure (Varnat i') - --- | TODO nothing to test against - unsure if correct -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'BE i) where - get = go (0 :: i) - where - go i = do - w8 <- FP.anyWord8 - let i' = unsafeShiftL i 7 .|. (fromIntegral (clearBit w8 7) + 1) - if testVarintCont @cont w8 7 then go i' else pure (Varnat (i'-1)) - --- | protobuf (cont=on), LEB128 (cont=on) --- --- not truly infinite length since shifters take 'Int', but practically infinite -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Redundant cont 'LE i) where - get = go (0 :: i) (0 :: Int) - where - go i n = do - w8 <- FP.anyWord8 - let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7)) n - if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat i') - --- | Git varint (cont=on), BPS (beat patches) (cont=off) -instance (VarintContinuation cont, Integral i, Bits i) => Get (Varnat 'Bijective cont 'LE i) where - get = go (0 :: i) (0 :: Int) - where - go i n = do - w8 <- FP.anyWord8 - let i' = i .|. unsafeShiftL (fromIntegral (clearBit w8 7) + 1) n - if testVarintCont @cont w8 7 then go i' (n+7) else pure (Varnat (i'-1)) - --- TODO uses fromIntegral's overflow behaviour -instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'LE i) where - put (Varnat i) = do - if i < 0b10000000 then - put @Word8 $ fromIntegral i - else - put @Word8 (setVarintCont @cont (fromIntegral i) 7) - <> put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7)) - --- TODO BE. Hard. -instance (VarintContinuation cont, Integral i, Bits i) => Put (Varnat 'Redundant cont 'BE i) where - put (Varnat i) = do - if i < 0b10000000 then - put @Word8 $ fromIntegral i - else - put @(Varnat 'Redundant cont 'LE i) (Varnat (unsafeShiftR i 7)) - <> put @Word8 (setVarintCont @cont (fromIntegral (i .&. 0b11111111)) 7) - --------------------------------------------------------------------------------- - -class VarintContinuation (cont :: ContinuationBitBehaviour) where - varintContinue :: Bool -instance VarintContinuation 'OnContinues where varintContinue = True -instance VarintContinuation 'OffContinues where varintContinue = False - -testVarintCont - :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> Bool -testVarintCont a n = case varintContinue @cont of True -> b - False -> not b - where b = testBit a n - -setVarintCont - :: forall cont a. VarintContinuation cont => Bits a => a -> Int -> a -setVarintCont = case varintContinue @cont of True -> setBit - False -> clearBit diff --git a/src/Binrep/Type/Vector.hs b/src/Binrep/Type/Vector.hs deleted file mode 100644 --- a/src/Binrep/Type/Vector.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Sized vectors. - -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Binrep.Type.Vector where - -import Binrep -import Data.Vector.Sized qualified as V -import Data.Vector.Sized ( Vector ) -import GHC.TypeNats - -instance BLen a => BLen (Vector n a) where - type CBLen (Vector n a) = CBLen a * n - blen = V.sum . V.map blen - -instance Put a => Put (Vector n a) where - put = mconcat . V.toList . V.map put - -instance (Get a, KnownNat n) => Get (Vector n a) where - get = getVector get - -getVector :: KnownNat n => Getter a -> Getter (Vector n a) -getVector g = V.replicateM g diff --git a/src/Binrep/Util.hs b/src/Binrep/Util.hs deleted file mode 100644 --- a/src/Binrep/Util.hs +++ /dev/null @@ -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'' #-} diff --git a/src/Binrep/Util/ByteOrder.hs b/src/Binrep/Util/ByteOrder.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/ByteOrder.hs @@ -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" diff --git a/src/Binrep/Util/Generic.hs b/src/Binrep/Util/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Binrep/Util/Generic.hs @@ -0,0 +1,19 @@ +module Binrep.Util.Generic where + +import GHC.TypeLits + +-- | Common type error string for when GHC is asked to derive a non-sum +-- instance, but the data type in question turns out to be a sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type EUnexpectedSum = + 'Text "Cannot derive non-sum binary representation instance for sum data type" + +-- | Common type error string for when GHC is asked to derive a sum instance, +-- but the data type in question turns out to be a non-sum data type. +-- +-- No need to add the data type name here, since GHC's context includes the +-- surrounding instance declaration. +type EUnexpectedNonSum = + 'Text "Refusing to derive sum binary representation instance for non-sum data type" diff --git a/src/Data/Aeson/Extra/SizedVector.hs b/src/Data/Aeson/Extra/SizedVector.hs deleted file mode 100644 --- a/src/Data/Aeson/Extra/SizedVector.hs +++ /dev/null @@ -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' diff --git a/src/Haskpatch/Format/Bps.hs b/src/Haskpatch/Format/Bps.hs deleted file mode 100644 --- a/src/Haskpatch/Format/Bps.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Haskpatch.Format.Bps where - -import Binrep.Type.Magic -import Binrep.Type.Sized -import Binrep.Type.Varint -import Binrep.Type.Common -import Strongweak - -import Data.ByteString qualified as B - --- | TODO --- * can't do generic because BPS doesn't store command list length, instead --- requiring a dynamic check on every command --- * wonder if this is better or more efficient that using a 'BpsVarint' for --- the length, same as metadata, or storing the end size as a 'BpsVarint'. --- * maybe two diff types of varint, +ve and -ve. unclear from spec --- * perhaps store the varint type(s) as a type var, to allow switching --- between efficient machine ints and safe 'Integer', 'Natural'! -data Bps (s :: Strength) i a = Bps - { bpsMagic :: SW s (Magic "BPS1") - , bpsSourceSize :: SW s (BpsVarint i) - , bpsTargetSize :: SW s (BpsVarint i) - - , bpsMetadata :: BpsMeta a - -- ^ Optional metadata. According to the specification, this should - -- "officially" be XML version 1.0 encoding UTF-8 data, but anything goes. - - , bpsCommands :: [BpsCommand] - , bpsFooter :: BpsFooter s - } - -type BpsVarint = Varnat 'Bijective 'OffContinues 'LE - -data BpsMeta a - -data BpsCommand - = BpsCommandSourceRead - | BpsCommandTargetRead - | BpsCommandSourceCopy - | BpsCommandTargetCopy - -data BpsFooter (s :: Strength) = BpsFooter - { bpsFooterSourceChecksum :: SW s (Sized 4 B.ByteString) - , bpsFooterTargetChecksum :: SW s (Sized 4 B.ByteString) - , bpsFooterPatchChecksum :: SW s (Sized 4 B.ByteString) - } diff --git a/src/Haskpatch/Format/Vcdiff.hs b/src/Haskpatch/Format/Vcdiff.hs deleted file mode 100644 --- a/src/Haskpatch/Format/Vcdiff.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | https://datatracker.ietf.org/doc/html/rfc3284 - -module Haskpatch.Format.Vcdiff where - -import Binrep.Type.Magic -import Binrep.Type.Varint -import Binrep.Type.Common -import Strongweak - -import Numeric.Natural -import Data.ByteString ( ByteString ) -import Data.Word ( Word8 ) - -data Vcdiff (s :: Strength) = Vcdiff - { vcdiffHeader :: Header s - } - -data Header (s :: Strength) = Header - { headerMagic :: SW s (Magic '[0xD6, 0xC3, 0xC4, 0x00]) - -- ^ First 3 bytes are @VCD@ each with their MSB on. - - , headerIndicator :: SW s (Magic '[0x00]) - -- ^ TODO annoying and impacts rest of format. forcing to 0x00 to simplify - } - -data Window (s :: Strength) = Window - { windowIndicator :: SW s (Magic '[0x00]) -- TODO - , windowDelta :: Delta s - } - -data Delta (s :: Strength) = Delta - { deltaIndicator :: SW s (Magic '[0x00]) -- TODO compression indicators. ignoring - , deltaAddRun :: ByteString - , deltaInstrs :: [InstrCode] - , deltaCopy :: ByteString - } - -data InstrCode = InstrCode - { instrCodeTriple1 :: InstrTriple - , instrCodeTriple2 :: InstrTriple - } - -data InstrTriple = InstrTriple - { instrTripleInstr :: Instr - - , instrTripleSize :: Word8 - - , instrTripleMode :: Word8 - -- ^ 0 and meaningless unless instr is a COPY - } - --- TODO singletons it -data Instr = Instr0Noop | Instr1Add | Instr2Run | Instr3Copy - --- | Apparently from the Sfio library, also similar (but not identical) to BPS's --- varints. -type VcdiffVarint = Varnat 'Redundant 'OnContinues 'BE Natural diff --git a/src/Raehik/Compat/FlatParse/Basic/CutWithPos.hs b/src/Raehik/Compat/FlatParse/Basic/CutWithPos.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/CutWithPos.hs @@ -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' #-} diff --git a/src/Raehik/Compat/FlatParse/Basic/Prim.hs b/src/Raehik/Compat/FlatParse/Basic/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/Prim.hs @@ -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) diff --git a/src/Raehik/Compat/FlatParse/Basic/Remaining.hs b/src/Raehik/Compat/FlatParse/Basic/Remaining.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/Remaining.hs @@ -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 #-} diff --git a/src/Raehik/Compat/FlatParse/Basic/WithLength.hs b/src/Raehik/Compat/FlatParse/Basic/WithLength.hs new file mode 100644 --- /dev/null +++ b/src/Raehik/Compat/FlatParse/Basic/WithLength.hs @@ -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 #-} diff --git a/src/Util/Generic.hs b/src/Util/Generic.hs deleted file mode 100644 --- a/src/Util/Generic.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} - -module Util.Generic where - -import GHC.Generics - --- | 'datatypeName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -datatypeName' :: forall d. Datatype d => String -datatypeName' = datatypeName @d undefined - --- | 'conName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -conName' :: forall c. Constructor c => String -conName' = conName @c undefined - --- | 'selName' without the value (only used as a proxy). Lets us push our --- 'undefined's into one place. -selName' :: forall s. Selector s => String -selName' = selName @s undefined - --- | Get the record name for a selector if present. --- --- On the type level, a 'Maybe Symbol' is stored for record names. But the --- reification is done using @fromMaybe ""@. So we have to inspect the resulting --- string to determine whether the field uses record syntax or not. (Silly.) -selName'' :: forall s. Selector s => Maybe String -selName'' = case selName' @s of "" -> Nothing - s -> Just s diff --git a/src/Util/TypeNats.hs b/src/Util/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/Util/TypeNats.hs @@ -0,0 +1,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 #-} diff --git a/test/ArbitraryOrphans.hs b/test/ArbitraryOrphans.hs --- a/test/ArbitraryOrphans.hs +++ b/test/ArbitraryOrphans.hs @@ -1,10 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} module ArbitraryOrphans() where import Test.QuickCheck ( Arbitrary ) -import Binrep.Type.Int ( I(..), IRep ) +import Binrep.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) diff --git a/test/Binrep/Extra/HexByteStringSpec.hs b/test/Binrep/Extra/HexByteStringSpec.hs deleted file mode 100644 --- a/test/Binrep/Extra/HexByteStringSpec.hs +++ /dev/null @@ -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" diff --git a/test/Binrep/GenericSpec.hs b/test/Binrep/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Binrep/GenericSpec.hs @@ -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 + -} diff --git a/test/Binrep/LawsSpec.hs b/test/Binrep/LawsSpec.hs deleted file mode 100644 --- a/test/Binrep/LawsSpec.hs +++ /dev/null @@ -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 diff --git a/test/Binrep/TypesSpec.hs b/test/Binrep/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Binrep/TypesSpec.hs @@ -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)