flat 0.3.4 → 0.6
raw patch · 89 files changed
Files
- CHANGELOG +43/−4
- README.md +52/−106
- flat.cabal +307/−124
- src/Data/ByteString/Convert.hs +10/−7
- src/Data/Flat.hs +0/−19
- src/Data/Flat/Bits.hs +0/−72
- src/Data/Flat/Class.hs +0/−453
- src/Data/Flat/Decoder.hs +0/−47
- src/Data/Flat/Decoder/Prim.hs +0/−391
- src/Data/Flat/Decoder/Strict.hs +0/−245
- src/Data/Flat/Decoder/Types.hs +0/−137
- src/Data/Flat/Encoder.hs +0/−68
- src/Data/Flat/Encoder/Prim.hs +0/−402
- src/Data/Flat/Encoder/Size.hs +0/−178
- src/Data/Flat/Encoder/Strict.hs +0/−246
- src/Data/Flat/Encoder/Types.hs +0/−25
- src/Data/Flat/Endian.hs +0/−61
- src/Data/Flat/Filler.hs +0/−60
- src/Data/Flat/Instances.hs +0/−230
- src/Data/Flat/Memory.hs +0/−113
- src/Data/Flat/Run.hs +0/−44
- src/Data/Flat/Types.hs +0/−28
- src/Data/FloatCast.hs +68/−46
- src/Data/ZigZag.hs +111/−50
- src/Flat.hs +21/−0
- src/Flat/AsBin.hs +120/−0
- src/Flat/AsSize.hs +65/−0
- src/Flat/Bits.hs +114/−0
- src/Flat/Class.hs +484/−0
- src/Flat/Decoder.hs +51/−0
- src/Flat/Decoder/Prim.hs +439/−0
- src/Flat/Decoder/Run.hs +71/−0
- src/Flat/Decoder/Strict.hs +288/−0
- src/Flat/Decoder/Types.hs +140/−0
- src/Flat/Encoder.hs +79/−0
- src/Flat/Encoder/Prim.hs +541/−0
- src/Flat/Encoder/Size.hs +192/−0
- src/Flat/Encoder/Strict.hs +324/−0
- src/Flat/Encoder/Types.hs +25/−0
- src/Flat/Endian.hs +72/−0
- src/Flat/Filler.hs +85/−0
- src/Flat/Instances.hs +15/−0
- src/Flat/Instances/Array.hs +72/−0
- src/Flat/Instances/Base.hs +713/−0
- src/Flat/Instances/ByteString.hs +87/−0
- src/Flat/Instances/Containers.hs +120/−0
- src/Flat/Instances/DList.hs +27/−0
- src/Flat/Instances/Extra.hs +20/−0
- src/Flat/Instances/Mono.hs +239/−0
- src/Flat/Instances/Test.hs +48/−0
- src/Flat/Instances/Text.hs +91/−0
- src/Flat/Instances/Unordered.hs +47/−0
- src/Flat/Instances/Util.hs +46/−0
- src/Flat/Instances/Vector.hs +45/−0
- src/Flat/Memory.hs +126/−0
- src/Flat/Run.hs +75/−0
- src/Flat/Tutorial.hs +116/−0
- src/Flat/Types.hs +20/−0
- stack.yaml +41/−11
- test/Big.hs +89/−0
- test/DocTest.hs +169/−0
- test/DocTest/Data/FloatCast.hs +11/−0
- test/DocTest/Data/ZigZag.hs +15/−0
- test/DocTest/Flat/AsBin.hs +18/−0
- test/DocTest/Flat/AsSize.hs +17/−0
- test/DocTest/Flat/Bits.hs +12/−0
- test/DocTest/Flat/Decoder/Prim.hs +15/−0
- test/DocTest/Flat/Encoder/Prim.hs +14/−0
- test/DocTest/Flat/Endian.hs +10/−0
- test/DocTest/Flat/Instances/Array.hs +16/−0
- test/DocTest/Flat/Instances/Base.hs +22/−0
- test/DocTest/Flat/Instances/ByteString.hs +14/−0
- test/DocTest/Flat/Instances/Containers.hs +16/−0
- test/DocTest/Flat/Instances/DList.hs +14/−0
- test/DocTest/Flat/Instances/Extra.hs +10/−0
- test/DocTest/Flat/Instances/Mono.hs +14/−0
- test/DocTest/Flat/Instances/Text.hs +15/−0
- test/DocTest/Flat/Instances/Unordered.hs +16/−0
- test/DocTest/Flat/Instances/Vector.hs +14/−0
- test/DocTest/Flat/Tutorial.hs +15/−0
- test/DocTests.hs +6/−0
- test/Spec.hs +782/−606
- test/Test/Data.hs +159/−93
- test/Test/Data/Arbitrary.hs +18/−8
- test/Test/Data/Flat.hs +78/−73
- test/Test/Data/Values.hs +41/−12
- test/Test/Data2/Flat.hs +1/−1
- test/Test/E.hs +1/−1
- test/Test/E/Flat.hs +4/−4
CHANGELOG view
@@ -1,15 +1,54 @@ Significant and compatibility-breaking changes. ++Version 0.6:+ - [**breaking**] Renamed Repr to AsBin and SizeOf to AsSize+ - Faster AsBin implementation + - Fixed AsSize implementation (SizeOf worked only for types with custom size implementation and returned max size, not actual size)++Version 0.5.2:+ - Fixed https://github.com/Quid2/flat/issues/28 that could cause an undetected overflow when decoding out of range Int/Word values+ - Added UTF16Text and Data.ByteString.Short support for ghcjs+ - Improved speed and accuracy of encoded Text size calculation (for encoding)+ - [**breaking**] Removed `textBytes` from Flat.Encoder.Size (breaking but insignificant)++Version 0.5:+ - Compatibility with ghc 9.0.2 & 9.2.4 & 9.4.2+ - Compatibility with text-2.0 (GHC)+ - Fixed https://github.com/Quid2/flat/issues/23 that could cause an encoding failure for non byte aligned Arrays + - Fixed https://github.com/Quid2/flat/pull/26 that could cause the decoder to read beyond the end of the decoding buffer (causing a SEGFAULT on ghcjs)+ - Merged https://github.com/Quid2/flat/pull/22 - fails correctly on invalid UTF-8 text + - Added a few ways to partially or incrementally decode values, see Flat.Repr and Flat.Decoder.Run.listTDecoder+ - Moved strictDecoder from Flat.Decoder.Types to Flat.Decoder+ - Removed Flat instance for Semigroup.Option from Flat.Instances.Base+ - Moved overlapping/specialised Flat instance for [Char] to Flat.Instances.Extra+ - Added a few extra functions++Version 0.4.4:+ - Added instances for Identity, Monoid.Dual/All/Any/Sum/Product/Alt, Semigroup.Min/Max/First/Last/Option ++Version 0.4.2:+ - Fixed links in README.md+ - Added multiple stack.yaml files for different LTS++Version 0.4:+ - Compatibility with ghc 8.8.3+ - Data.Seq.Seq is serialised as a List (previously was serialised as an Array)+ - Changed namespace from Data.Flat to Flat+ - Addtional Flat Instances for some common packages: array, base, bytestring, containers, dlist, text, unordered-containers, vector+ - Additional doctests, with a static version that can run without ghci and therefore also under ghcjs/eta (run it with stack test :doc-static)+ - Many minor changes+ Version 0.3.4: - Redisegned Generics-based instance generation (Data.Flat.Class) to reduce compilation time and improve encoding and decoding performance - Fixed GHCJS Double bug and tested GHCJS with full test suite +Version 0.3.2:+ - Tested with ghc 8.2.1+ - Dropped dependencies on the 'cpu', 'derive' and 'tasty' packages to make it compatible with the Eta compiler (https://github.com/typelead/eta)+ Version 0.3: - Removed 'flatStrict' and 'unflatStrict' (use 'flat' and 'unflat' instead that also encode/decode strictly) - `unflatWith` now takes a decoder for the unpadded value (previously it expected a padded decoder) and decodes the padded value - Added some decoding primitives - Added Data.ByteString.Convert--Version 0.3.1:- - Tested with ghc 8.2.1- - Dropped dependencies on the 'cpu', 'derive' and 'tasty' packages to make it compatible with the Eta compiler (https://github.com/typelead/eta)
README.md view
@@ -1,175 +1,121 @@ -[](https://travis-ci.org/Quid2/flat)++ [](http://hackage.haskell.org/package/flat) -Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and efficient binary data format ([specs](http://quid2.org)).+[](http://stackage.org/lts/package/flat)+[](http://stackage.org/lts/package/flat)+[](http://stackage.org/lts/package/flat)+[](http://stackage.org/nightly/package/flat) -### How To Use It For Fun and Profit+Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and compact binary data format ([specs](http://quid2.org)). -To (de)serialise a data type, make it an instance of the `Flat` class. -There is `Generics` based support to automatically derive instances of additional types.--Let's see some code, we need a couple of extensions:+### How To Use It For Fun and Profit ```haskell {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} ``` -Import the Flat library:- ```haskell-import Data.Flat+import Flat ``` -Define a couple of custom data types, deriving Generic and Flat: -```haskell-data Direction = North | South | Center | East | West deriving (Show,Generic,Flat)-``` ```haskell-data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat)+data Direction = North | South | Center | East | West deriving (Show,Generic,Flat) ``` -For encoding, use `flat`, for decoding, use `unflat`:+Use **flat** to encode: ```haskell-unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction)--> Right (Cons North (Cons South Nil))+flat [North,South]+-> "\149" ``` -For the decoding to work correctly, you will naturally need to know the type of the serialised data. This is ok for applications that do not require long-term storage and that do not need to communicate across independently evolving agents. For those who do, you will need to supplement `flat` with something like [zm](https://github.com/Quid2/zm).--#### Define Instances for Abstract/Primitive types-- A set of primitives are available to define `Flat` instances for abstract or primitive types.-- Instances for some common, primitive or abstract data types (Bool,Words,Int,String,Text,ByteStrings,Tuples, Lists, Sequences, Maps ..) are already defined in [Data.Flat.Instances](https://github.com/Quid2/flat/blob/master/src/Data/Flat/Instances.hs).--#### Optimal Bit-Encoding--A pecularity of Flat is that it uses an optimal bit-encoding rather than the usual byte-oriented one.-- To see this, let's define a pretty printing function: `bits` encodes a value as a sequence of bits, `prettyShow` displays it nicely:+and **unflat** to decode: ```haskell-p :: Flat a => a -> String-p = prettyShow . bits+unflat (flat [North,South]) :: Decoded [Direction]+-> Right [ North , South ] ``` -Now some encodings: -```haskell-p West--> "111"-```-+And thanks to Flat's bit-encoding, this list fits in 1 byte (rather than the 5 bytes that would be required by a traditional byte encoding): ```haskell-p (Nil::List Direction)--> "0"+flatBits [North,South]+-> "10010101" ``` -```haskell-aList = Cons North (Cons South (Cons Center (Cons East (Cons West Nil))))-p aList--> "10010111 01110111 10"-``` --As you can see, `aList` fits in less than 3 bytes rather than 11 as would be the case with other Haskell byte oriented serialisation packages like `binary` or `store`.--For the serialisation to work with byte-oriented devices or storage, we need to add some padding:--```haskell-f :: Flat a => a -> String-f = prettyShow . paddedBits-```--```haskell-f West--> "11100001"-```-+### Performance -```haskell-f (Nil::List Direction)--> "00000001"-```+For some hard data, see this [comparison of the major haskell serialisation libraries](https://github.com/haskell-perf/serialization). +Briefly:+ * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually)+ * Serialization time: `store`, `persist` and `flat` are faster+ * Deserialization time: `store`, `flat`, `persist` and `cereal` are faster+ * Transfer time (serialisation time + transport time on the network + deserialisation at the receiving end): `flat` is usually faster for all but the highest network speeds -```haskell-f $ Cons North (Cons South (Cons Center (Cons East (Cons West Nil))))--> "10010111 01110111 10000001"-```+### Documentation -The padding is a sequence of 0s terminated by a 1 running till the next byte boundary (if we are already at a byte boundary it will add an additional byte of value 1, that's unfortunate but there is a good reason for this, check the [specs](http://quid2.org/docs/Flat.pdf)).+* [Tutorial](http://hackage.haskell.org/package/flat/docs/Flat-Tutorial.html) -Byte-padding is automatically added by the function `flat` and removed by `unflat`.+* [Hackage Package and Docs](http://hackage.haskell.org/package/flat) -### Performance+* [Flat Format Specification](http://quid2.org/docs/Flat.pdf) -For some hard data, see this [comparison of the major haskell serialisation libraries](https://github.com/haskell-perf/serialization).+### Installation -Briefly:- * Size: `flat` produces significantly smaller binaries than all other libraries (3/4 times usually)- * Encoding: `store` and `flat` are usually faster- * Decoding: `store`, `flat` and `cereal` are usually faster- * Transfer time (serialisation time + transport time on the network + deserialisation at the receiving end): `flat` is usually faster for all but the highest network speeds+Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat). ### Compatibility -#### [GHC](https://www.haskell.org/ghc/) - Tested with:- * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2, 8.2.2, 8.4.4 and 8.6.1 (x64) -Should also work with (not recently tested):- * [ghc](https://www.haskell.org/ghc/) 7.10.3/LLVM 3.5.2 (Arm7)+* [GHC](https://www.haskell.org/ghc/) 7.10.3 to 9.4.3 (x64) -#### [GHCJS](https://github.com/ghcjs/ghcjs)- -Passes all tests in the `flat` testsuite, except for those relative to short bytestrings (Data.ByteString.Short) that are unsupported by `ghcjs`. -Check [stack-ghcjs.yaml](https://github.com/Quid2/flat/blob/master/stack-ghcjs.yaml) to see with what versions of `ghcjs` it has been tested.+* [GHCJS](https://github.com/ghcjs/ghcjs) version 8.6.0.1 (GHC 8.6.2) -If you use a different version of `ghcjs`, you might want to run the test suite by setting your compiler in [stack-ghcjs.yaml](https://github.com/Quid2/flat/blob/master/stack-ghcjs.yaml) and then running: -`stack test --stack-yaml=stack-ghcjs.yaml` -NOTE: Versions prior to 0.33 encode `Double` values incorrectly when they are not aligned with a byte boundary.+### Known Bugs and Infelicities -NOTE: A native [TypeScript/JavaScript version](https://github.com/Quid2/ts) of `flat` is under development.+* Data types with more than 512 constructors are currently unsupported (but support could be easily added if necessary) -#### [ETA](https://eta-lang.org/)+* Longish compilation times -It builds (with etlas 1.5.0.0 and eta eta-0.8.6b2 under macOS Sierra) and seems to be working, though the full test suite could not be run due to Eta's issues compiling some of the test suite dependencies.+ * To improve performance, `flat` relies on extensive inlining. This unfortunately leads to longer compilation times. -### Installation+ If you have many data types or very large ones, you might want to: -Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat).+ * During development, turn optimisations off (`stack --fast` or `-O0` in the cabal file). -### Known Bugs and Infelicities+ * Keep your serialisation code in separate modules. -#### Longish compilation times+* See also the [full list of open issues](https://github.com/Quid2/flat/issues). -'flat` relies more than other serialisation libraries on extensive inlining for its good performance, this unfortunately leads to longer compilation times. +### Ports for other languages -If you have many data types or very large ones this might become an issue.+[Rust](https://www.rust-lang.org/) and [TypeScript-JavaScript](https://github.com/Quid2/ts) ports are under development. -A couple of good practices that will eliminate or mitigate this problem are: -* During development, turn optimisations off (`stack --fast` or `-O0` in the cabal file).+Get in touch if you would like to help porting `flat` to other languages. -* Keep your serialisation code in a separate module(s).+### Acknowledgements -#### Data types with more than 512 constructors are currently unsupported+`flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes bug fixes from a number of contributors. -See also the [full list of open issues](https://github.com/Quid2/flat/issues).+### Other Stuff You Might Like -### Acknowledgements+To decode `flat` encoded data you need to know the type of the serialised data. - `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes contributions from Justus Sagemüller.+This is ok for applications that do not require long-term storage and that do not operate in open distributed systems.++For those who do, you might want to supplement `flat` with [ZM - Language independent, reproducible, absolute types](https://github.com/Quid2/zm).
flat.cabal view
@@ -1,140 +1,323 @@-name: flat-version: 0.3.4-synopsis: Principled and efficient bit-oriented binary serialization.-description: Principled and efficient bit-oriented binary serialization, check the <http://github.com/Quid2/flat online tutorial>.-homepage: http://quid2.org-category: Data,Parsing,Serialization-license: BSD3-license-file: LICENSE-author: Pasqualino `Titto` Assini-maintainer: tittoassini@gmail.com-copyright: Copyright: (c) 2016-2018 Pasqualino `Titto` Assini-cabal-version: >=1.10-build-type: Simple-Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.1+cabal-version: >=1.10+name: flat+version: 0.6+homepage: http://quid2.org+synopsis: Principled and efficient bit-oriented binary serialization.+description:+ Reference implementation of `flat`, a principled and efficient binary serialization format. +category: Data,Parsing,Serialization+license: BSD3+license-file: LICENSE+copyright: Copyright: (c) 2016-2022 Pasqualino `Titto` Assini+maintainer: tittoassini@gmail.com+author: Pasqualino `Titto` Assini+tested-with:+ GHC ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.4+ || ==9.4.3++build-type: Simple extra-source-files:- stack.yaml- README.md- CHANGELOG+ stack.yaml+ README.md+ CHANGELOG source-repository head- type: git- location: https://github.com/Quid2/flat+ type: git+ location: https://github.com/Quid2/flat library- exposed-modules:- Data.ByteString.Convert- Data.Flat.Bits- Data.Flat.Class- Data.Flat.Decoder- Data.Flat.Decoder.Prim- Data.Flat.Decoder.Strict- Data.Flat.Decoder.Types- Data.Flat.Encoder- Data.Flat.Encoder.Prim- Data.Flat.Encoder.Size- Data.Flat.Encoder.Strict- Data.Flat.Encoder.Types- Data.Flat.Filler- Data.Flat.Memory- Data.Flat.Run- Data.Flat.Types- Data.Flat- Data.FloatCast- Data.ZigZag- Data.Flat.Instances- Data.Flat.Endian + exposed-modules:+ Data.ByteString.Convert+ Data.FloatCast+ Data.ZigZag+ Flat+ Flat.AsBin+ Flat.AsSize+ Flat.Bits+ Flat.Class+ Flat.Decoder+ Flat.Decoder.Prim+ Flat.Decoder.Run+ Flat.Decoder.Strict+ Flat.Decoder.Types+ Flat.Encoder+ Flat.Encoder.Prim+ Flat.Encoder.Size+ Flat.Encoder.Strict+ Flat.Encoder.Types+ Flat.Endian+ Flat.Filler+ Flat.Instances+ Flat.Instances.Array+ Flat.Instances.Base+ Flat.Instances.ByteString+ Flat.Instances.Containers+ Flat.Instances.DList+ Flat.Instances.Extra+ Flat.Instances.Mono+ Flat.Instances.Test+ Flat.Instances.Text+ Flat.Instances.Unordered+ Flat.Instances.Util+ Flat.Instances.Vector+ Flat.Memory+ Flat.Run+ Flat.Tutorial+ Flat.Types + hs-source-dirs: src+ default-language: Haskell2010+ other-extensions:+ NoMonomorphismRestriction+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ FlexibleContexts+ FlexibleInstances+ OverloadedStrings+ PolyKinds+ ScopedTypeVariables+ TupleSections+ TypeFamilies+ TypeOperators+ UndecidableInstances++ ghc-options:+ -Wall -O2 -funbox-strict-fields -fno-warn-orphans+ -fno-warn-name-shadowing++ -- -Werror++ -- Stan options+ -- -fwrite-ide-info -hiedir=.hie++ if impl(eta -any) build-depends:- base >=4.8 && <5- , bytestring>=0.10.6- , deepseq >= 1.4- , ghc-prim- , primitive- , text- , array >= 0.5.1.0- , dlist >= 0.6- , vector- , pretty >= 1.1.2- - -- Required by Data.Flat.Instances- , containers- , mono-traversable>=0.10.0.2+ array ==0.5.2.0+ , base+ , bytestring ==0.10.8.2+ , containers ==0.5.9.1+ , deepseq ==1.4.3.0+ , dlist+ , filepath ==1.4.1.1+ , ghc-prim ==0.4.0.0+ , hashable >=1.2.4.0 && <=1.2.7.0+ , HUnit ==1.6.0.0+ , memory >=0.14.10 && <=0.14.14+ , mono-traversable ==1.0.1+ , pretty >=1.1.3.4 && <=1.1.3.6+ , primitive >=0.6.1.0 && <=0.6.4.0+ , QuickCheck ==2.10+ , tasty ==1.1.0.3+ , text ==1.2.3.0+ , unordered-containers >=0.2.7.1 && <=0.2.9.0+ , vector >=0.11.0.0 && <=0.12.0.1 - if impl(ghc < 8.0)- build-depends: semigroups+ else+ build-depends:+ array >=0.5.1.0+ , base >=4.8 && <5+ , bytestring >=0.10.6+ , containers+ , deepseq >=1.4+ , dlist >=0.6+ , ghc-prim+ , list-t >1+ , mono-traversable+ , pretty >=1.1.2+ , primitive+ , text+ , unordered-containers+ , vector - default-language: Haskell2010- other-extensions: DataKinds DefaultSignatures DeriveAnyClass- DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable- FlexibleContexts FlexibleInstances NoMonomorphismRestriction- OverloadedStrings PolyKinds ScopedTypeVariables TupleSections- TypeFamilies TypeOperators UndecidableInstances- hs-source-dirs: src- ghc-options: -Wall -O2 -funbox-strict-fields -fno-warn-orphans -fno-warn-name-shadowing+ if impl(ghc <8)+ build-depends:+ hashable >=1.2.4.0 && <=1.2.7.0+ , semigroups >=0 && <0.19 --- Full test suite+ else+ build-depends: hashable >=1.4.0.1+ test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ cpp-options: -DLIST_BIT -DTEST_DECBITS++ -- if impl(ghc <8.6)+ cpp-options: -DENUM_LARGE++ -- -DETA_VERSION -Dghcjs_HOST_OS++ ghc-options: -O0++ if impl(ghc >8)+ ghc-options:+ -Wno-unused-top-binds -Wno-type-defaults -Wno-missing-signatures++ hs-source-dirs: test+ other-modules:+ Test.Data+ Test.Data.Arbitrary+ Test.Data.Flat+ Test.Data.Values+ Test.Data2+ Test.Data2.Flat+ Test.E+ Test.E.Arbitrary+ Test.E.Flat++ default-language: Haskell2010+ build-depends:+ base+ , flat+ , ghc-prim+ , quickcheck-text+ , tasty-hunit+ , tasty-quickcheck+ , text++ if impl(ghc <8)+ build-depends: semigroups <0.19++ if impl(eta -any) build-depends:- base- , ghc-prim- , tasty - -- >= 1- , tasty-hunit - -- >= 0.8- , tasty-quickcheck - -- >=0.9- , containers- , deepseq == 1.4.*- , QuickCheck >= 2.10- , text- , bytestring- , array- , flat+ array ==0.5.2.0+ , bytestring ==0.10.8.2+ , containers ==0.5.9.1+ , deepseq ==1.4.3.0+ , filepath ==1.4.1.1+ , HUnit ==1.6.0.0+ , mono-traversable ==1.0.1+ , QuickCheck ==2.10+ , tasty ==1.1.0.3+ , text ==1.2.3.0 - default-language: Haskell2010- hs-source-dirs: test- cpp-options: -DLIST_BIT - -- Add large data types test- -- cpp-options: -DENUM_LARGE- -- Add low level decoding test - -- cpp-options: -DTEST_DECBITS- other-modules:- Test.Data- Test.Data2- Test.E- Test.E.Flat- Test.E.Arbitrary- Test.Data.Arbitrary- Test.Data.Flat- Test.Data2.Flat- Test.Data.Values+ else+ build-depends:+ array+ , bytestring+ , containers+ , deepseq+ , filepath+ , mono-traversable+ , QuickCheck >=2.14.2+ , tasty+ , text --- Tests embedded in code documentation (won't compile with ghcjs)--- test-suite docs--- default-language: Haskell2010--- type: exitcode-stdio-1.0--- main-is: DocSpec.hs--- build-depends: base, doctest>=0.11.2,filemanip>=0.3.6.3--- HS-Source-Dirs: test+-- dynamic doctests and generation of static doctests+-- Usable only with recent versions of ghc (no ghcjs or eta) --- Simple benchmark (won't compile with ghcjs)--- benchmark sbench--- main-is: Mini.hs--- type: exitcode-stdio-1.0--- default-language: Haskell2010--- build-depends:--- base--- , deepseq--- ,criterion--- ,bytestring,text,containers,process,filepath,statistics,directory--- -- ,timeit--- ,flat--- hs-source-dirs: benchmarks test--- ghc-options: -O2 -dumpdir /tmp/dump -ddump-to-file -dsuppress-all -ddump-simpl -fprint-potential-instances--- -- cpp-options: -DENUM_LARGE--- other-modules:--- Test.E,Test.Data,Test.Data.Flat,Test.Data.Values,Test.Data2,Test.Data2.Flat,Test.E.Flat,Report+-- test-suite doc+-- type: exitcode-stdio-1.0+-- main-is: DocSpec.hs+-- hs-source-dirs: test+-- default-language: Haskell2010+-- build-depends:+-- base+-- , directory+-- , doctest ==0.16.3.1+-- , filemanip >=0.3.6.3+-- , QuickCheck >=2.14.2+-- , text++-- static doctests (faster, useful for test coverage and to test ghcjs and eta)+test-suite doc-static+ type: exitcode-stdio-1.0+ main-is: DocTests.hs+ hs-source-dirs: test+ other-modules:+ DocTest+ DocTest.Data.FloatCast+ DocTest.Data.ZigZag+ DocTest.Flat.AsBin+ DocTest.Flat.AsSize+ DocTest.Flat.Bits+ DocTest.Flat.Decoder.Prim+ DocTest.Flat.Encoder.Prim+ DocTest.Flat.Endian+ DocTest.Flat.Instances.Array+ DocTest.Flat.Instances.Base+ DocTest.Flat.Instances.ByteString+ DocTest.Flat.Instances.Containers+ DocTest.Flat.Instances.DList+ DocTest.Flat.Instances.Extra+ DocTest.Flat.Instances.Mono+ DocTest.Flat.Instances.Text+ DocTest.Flat.Instances.Unordered+ DocTest.Flat.Instances.Vector+ DocTest.Flat.Tutorial++ default-language: Haskell2010+ build-depends:+ array+ , base+ , bytestring+ , containers+ , dlist+ , flat+ , pretty+ , QuickCheck >=2.14.2+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , text+ , unordered-containers+ , vector++ if impl(ghc <8)+ build-depends: semigroups <0.19++-- Test for Flat.AsBin Flat.AsSize and listTDecoder+test-suite big+ type: exitcode-stdio-1.0+ main-is: Big.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ base+ , bytestring+ , flat+ , list-t+ , timeit++ ghc-options: -rtsopts++-- test-suite text+-- type: exitcode-stdio-1.0+-- main-is: TextSize.hs+-- hs-source-dirs: test+-- default-language: Haskell2010+-- build-depends:+-- base+-- , flat+-- , text <2++-- ghc-options: -rtsopts+++-- test-suite ghcjs+-- type: exitcode-stdio-1.0+-- main-is: GHCJS.hs+-- hs-source-dirs: test+-- default-language: Haskell2010+-- build-depends:+-- base+-- , flat+-- , bytestring+-- , jsaddle++-- ghc-options: -rtsopts+
src/Data/ByteString/Convert.hs view
@@ -1,24 +1,27 @@ {-# LANGUAGE FlexibleInstances #-}--- |Convert to/from strict ByteStrings-module Data.ByteString.Convert (AsByteString(..)) where+module Data.ByteString.Convert+ ( AsByteString(..)+ )+where -import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L import Data.Word +-- |Convert to/from strict ByteStrings class AsByteString a where toByteString :: a -> B.ByteString fromByteString :: B.ByteString -> a instance AsByteString B.ByteString where- toByteString = id+ toByteString = id fromByteString = id instance AsByteString L.ByteString where- toByteString = L.toStrict+ toByteString = L.toStrict fromByteString = L.fromStrict instance AsByteString [Word8] where- toByteString = B.pack+ toByteString = B.pack fromByteString = B.unpack
− src/Data/Flat.hs
@@ -1,19 +0,0 @@-module Data.Flat (- -- |Check the <https://github.com/Quid2/flat tutorial and github repo>.- module Data.Flat.Class,- module Data.Flat.Filler,- module Data.Flat.Instances,- module Data.Flat.Run,- UTF8Text(..),- UTF16Text(..),- Get,- Decoded,- DecodeException,- ) where--import Data.Flat.Class-import Data.Flat.Decoder-import Data.Flat.Filler-import Data.Flat.Instances-import Data.Flat.Run-import Data.Flat.Types
− src/Data/Flat/Bits.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}---- |Utilities to represent and display bit sequences-module Data.Flat.Bits (- Bits,- toBools,- fromBools,- bits,- paddedBits,- asBytes,- asBits,- ) where--import Data.Bits hiding (Bits)-import qualified Data.ByteString as B-import Data.Flat.Class-import Data.Flat.Decoder-import Data.Flat.Filler-import Data.Flat.Run-import qualified Data.Vector.Unboxed as V-import Data.Word-import Text.PrettyPrint.HughesPJClass---- |A sequence of bits-type Bits = V.Vector Bool--toBools :: Bits -> [Bool]-toBools = V.toList--fromBools :: [Bool] -> Bits-fromBools = V.fromList---- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding)-bits :: forall a. Flat a => a -> Bits-bits v = let lbs = flat v- Right (PostAligned _ f) = unflatRaw lbs :: Decoded (PostAligned a)- in takeBits (8 * B.length lbs - fillerLength f) lbs---- |The sequence of bits corresponding to the byte-padded serialization of the passed value-paddedBits :: forall a. Flat a => a -> Bits-paddedBits v = let lbs = flat v- in takeBits (8 * B.length lbs) lbs--takeBits :: Int -> B.ByteString -> Bits-takeBits numBits lbs = V.generate (fromIntegral numBits) (\n -> let (bb,b) = n `divMod` 8 in testBit (B.index lbs (fromIntegral bb)) (7-b))---- | asBits (5::Word8)--- | > [False,False,False,False,False,True,False,True]-asBits :: FiniteBits a => a -> Bits-asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s-1-))---- |Convert a sequence of bits to the corresponding list of bytes-asBytes :: Bits -> [Word8]-asBytes = map byteVal . bytes . V.toList---- |Convert to the corresponding value (most significant bit first)-byteVal :: [Bool] -> Word8-byteVal = sum . map (\(e,b) -> if b then e else 0). zip [2 ^ n | n <- [7::Int,6..0]]---- |Split a list in groups of 8 elements or less-bytes :: [t] -> [[t]]-bytes [] = []-bytes l = let (w,r) = splitAt 8 l in w : bytes r--instance Pretty Bits where pPrint = hsep . map prettyBits . bytes . V.toList--prettyBits :: Foldable t => t Bool -> Doc-prettyBits l = text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l-
− src/Data/Flat/Class.hs
@@ -1,453 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- |Generics-based generation of Flat instances-module Data.Flat.Class- (- -- * The Flat class- Flat(..)- , getSize- , module GHC.Generics- )-where--import Data.Bits-import Data.Flat.Decoder-import Data.Flat.Encoder-import Data.Word-import GHC.Generics-import GHC.TypeLits-import Prelude hiding (mempty)---- External and Internal inlining-#define INL 2--- Internal inlining--- #define INL 1--- No inlining--- #define INL 0--#if INL == 1-import GHC.Exts (inline)-#endif---- import Data.Proxy---- $setup--- >>> {-# LANGUAGE DataKinds #-}--- >>> import Data.Proxy---- |Calculate the maximum size in bits of the serialisation of the value-getSize :: Flat a => a -> NumBits-getSize a = size a 0---- |Class of types that can be encoded/decoded-class Flat a where- encode :: a -> Encoding- default encode :: (Generic a, GEncode (Rep a)) => a -> Encoding- encode = gencode . from-- decode :: Get a- default decode :: (Generic a, GDecode (Rep a)) => Get a- decode = to `fmap` gget-- size :: a -> NumBits -> NumBits- default size :: (Generic a, GSize (Rep a)) => a -> NumBits -> NumBits- size !x !n = gsize n $ from x--#if INL>=2- -- With these, generated code is optimised for specific data types (e.g.: Tree Bool will fuse the code of Tree and Bool)- -- This can improve performance very significantly (up to 10X) but also increases compilation times.- {-# INLINE size #-}- {-# INLINE decode #-}- {-# INLINE encode #-}-#elif INL == 1-#elif INL == 0- {-# NOINLINE size #-}- {-# NOINLINE decode #-}- {-# NOINLINE encode #-}-#endif---- Generic Encoder-class GEncode f where gencode :: f a -> Encoding--instance {-# OVERLAPPABLE #-} GEncode f => GEncode (M1 i c f) where- gencode = gencode . unM1- {-# INLINE gencode #-}-- -- Special case, single constructor datatype-instance {-# OVERLAPPING #-} GEncode a => GEncode (D1 i (C1 c a)) where- gencode = gencode . unM1 . unM1- {-# INLINE gencode #-}-- -- Type without constructors-instance GEncode V1 where- gencode = unused- {-# INLINE gencode #-}-- -- Constructor without arguments-instance GEncode U1 where- gencode U1 = mempty- {-# INLINE gencode #-}--instance Flat a => GEncode (K1 i a) where- {-# INLINE gencode #-}-#if INL == 1- gencode x = inline encode (unK1 x)-#else- gencode = encode . unK1-#endif--instance (GEncode a, GEncode b) => GEncode (a :*: b) where- --gencode (!x :*: (!y)) = gencode x <++> gencode y- gencode (x :*: y) = gencode x <> gencode y- {-# INLINE gencode #-}--instance (NumConstructors (a :+: b) <= 512,GEncodeSum (a :+: b)) => GEncode (a :+: b) where--- instance (GEncodeSum (a :+: b)) => GEncode (a :+: b) where- gencode = gencodeSum 0 0- {-# INLINE gencode #-}---- Constructor Encoding-class GEncodeSum f where- gencodeSum :: Word16 -> NumBits -> f a -> Encoding--instance (GEncodeSum a, GEncodeSum b) => GEncodeSum (a :+: b) where- gencodeSum !code !numBits s = case s of- L1 !x -> gencodeSum ((code `unsafeShiftL` 1)) (numBits+1) x- R1 !x -> gencodeSum ((code `unsafeShiftL` 1) .|. 1) (numBits+1) x- {-# INLINE gencodeSum #-}--instance GEncode a => GEncodeSum (C1 c a) where- gencodeSum !code !numBits x = eBits16 numBits code <> gencode x- {-# INLINE gencodeSum #-}---- Generic Decoding-class GDecode f where- gget :: Get (f t)---- Metadata (constructor name, etc)-instance GDecode a => GDecode (M1 i c a) where- gget = M1 <$> gget- {-# INLINE gget #-}---- Type without constructors-instance GDecode V1 where- gget = unused- {-# INLINE gget #-}---- Constructor without arguments-instance GDecode U1 where- gget = pure U1- {-# INLINE gget #-}---- Product: constructor with parameters-instance (GDecode a, GDecode b) => GDecode (a :*: b) where- gget = (:*:) <$> gget <*> gget- {-# INLINE gget #-}---- Constants, additional parameters, and rank-1 recursion-instance Flat a => GDecode (K1 i a) where-#if INL == 1- gget = K1 <$> inline decode-#else- gget = K1 <$> decode-#endif- {-# INLINE gget #-}----- Different valid decoding setups--- #define DEC_BOOLG--- #define DEC_BOOL---- #define DEC_BOOLG--- #define DEC_BOOL--- #define DEC_BOOL48---- #define DEC_CONS--- #define DEC_BOOLC--- #define DEC_BOOL---- #define DEC_CONS--- #define DEC_BOOLC--- #define DEC_BOOL--- #define DEC_BOOL48---- #define DEC_CONS---- #define DEC_CONS--- #define DEC_CONS48--#define DEC_CONS-#define DEC_CONS48-#define DEC_BOOLC-#define DEC_BOOL--#ifdef DEC_BOOLG-instance (GDecode a, GDecode b) => GDecode (a :+: b)-#endif--#ifdef DEC_BOOLC--- Special case for data types with two constructors-instance {-# OVERLAPPING #-} (GDecode a,GDecode b) => GDecode (C1 m1 a :+: C1 m2 b)-#endif--#ifdef DEC_BOOL- where- gget = do- -- error "DECODE2_C2"- !tag <- dBool- !r <- if tag then R1 <$> gget else L1 <$> gget- return r- {-# INLINE gget #-}-#endif--#ifdef DEC_CONS--- | Data types with up to 512 constructors--- Uses a custom constructor decoding state--- instance {-# OVERLAPPABLE #-} (GDecodeSum (a :+: b),GDecode a, GDecode b) => GDecode (a :+: b) where-instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GDecodeSum (a :+: b)) => GDecode (a :+: b) where- gget = do- cs <- consOpen- getSum cs- {-# INLINE gget #-}---- Constructor Decoder-class GDecodeSum f where- getSum :: ConsState -> Get (f a)--#ifdef DEC_CONS48---- Decode constructors in groups of 2 or 3 bits--- Significantly reduce instance compilation time and slightly improve execution times-instance {-# OVERLAPPING #-} (GDecodeSum n1,GDecodeSum n2,GDecodeSum n3,GDecodeSum n4) => GDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined- where- getSum cs = do- -- error "DECODE4"- let (cs',tag) = consBits cs 2- case tag of- 0 -> L1 . L1 <$> getSum cs'- 1 -> L1 . R1 <$> getSum cs'- 2 -> R1 . L1 <$> getSum cs'- _ -> R1 . R1 <$> getSum cs'- {-# INLINE getSum #-}--instance {-# OVERLAPPING #-} (GDecodeSum n1,GDecodeSum n2,GDecodeSum n3,GDecodeSum n4,GDecodeSum n5,GDecodeSum n6,GDecodeSum n7,GDecodeSum n8) => GDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined- where- getSum cs = do- --error "DECODE8"- let (cs',tag) = consBits cs 3- case tag of- 0 -> L1 . L1 . L1 <$> getSum cs'- 1 -> L1 . L1 . R1 <$> getSum cs'- 2 -> L1 . R1 . L1 <$> getSum cs'- 3 -> L1 . R1 . R1 <$> getSum cs'- 4 -> R1 . L1 . L1 <$> getSum cs'- 5 -> R1 . L1 . R1 <$> getSum cs'- 6 -> R1 . R1 . L1 <$> getSum cs'- _ -> R1 . R1 . R1 <$> getSum cs'- {-# INLINE getSum #-}--instance {-# OVERLAPPABLE #-} (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where-#else-instance (GDecodeSum a, GDecodeSum b) => GDecodeSum (a :+: b) where-#endif-- getSum cs = do- let (cs',tag) = consBool cs- if tag then R1 <$> getSum cs' else L1 <$> getSum cs'- {-# INLINE getSum #-}---instance GDecode a => GDecodeSum (C1 c a) where- getSum (ConsState _ usedBits) = consClose usedBits >> gget- {-# INLINE getSum #-}-#endif--#ifdef DEC_BOOL48-instance {-# OVERLAPPING #-} (GDecode n1,GDecode n2,GDecode n3,GDecode n4) => GDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined- where- gget = do- -- error "DECODE4"- !tag <- dBEBits8 2- case tag of- 0 -> L1 <$> L1 <$> gget- 1 -> L1 <$> R1 <$> gget- 2 -> R1 <$> L1 <$> gget- _ -> R1 <$> R1 <$> gget- {-# INLINE gget #-}--instance {-# OVERLAPPING #-} (GDecode n1,GDecode n2,GDecode n3,GDecode n4,GDecode n5,GDecode n6,GDecode n7,GDecode n8) => GDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined- where- gget = do- --error "DECODE8"- !tag <- dBEBits8 3- case tag of- 0 -> L1 <$> L1 <$> L1 <$> gget- 1 -> L1 <$> L1 <$> R1 <$> gget- 2 -> L1 <$> R1 <$> L1 <$> gget- 3 -> L1 <$> R1 <$> R1 <$> gget- 4 -> R1 <$> L1 <$> L1 <$> gget- 5 -> R1 <$> L1 <$> R1 <$> gget- 6 -> R1 <$> R1 <$> L1 <$> gget- _ -> R1 <$> R1 <$> R1 <$> gget- {-# INLINE gget #-}-#endif---- |Calculate the number of bits required for the serialisation of a value--- Implemented as a function that adds the maximum size to a running total-class GSize f where gsize :: NumBits -> f a -> NumBits---- Skip metadata-instance GSize f => GSize (M1 i c f) where- gsize !n = gsize n . unM1- {-# INLINE gsize #-}---- Type without constructors-instance GSize V1 where- gsize !n _ = n- {-# INLINE gsize #-}---- Constructor without arguments-instance GSize U1 where- gsize !n _ = n- {-# INLINE gsize #-}---- Skip metadata-instance Flat a => GSize (K1 i a) where-#if INL == 1- gsize !n x = inline size (unK1 x) n-#else- gsize !n x = size (unK1 x) n-#endif- {-# INLINE gsize #-}--instance (GSize a, GSize b) => GSize (a :*: b) where- gsize !n (x :*: y) = gsize (gsize n x) y- {-# INLINE gsize #-}---- Different size implementations-#define SIZ_ADD--- #define SIZ_NUM---- #define SIZ_MAX--- #define SIZ_MAX_VAL--- #define SIZ_MAX_PROX--#ifdef SIZ_ADD-instance (GSizeSum (a :+: b)) => GSize (a :+: b) where- gsize !n = gsizeSum n-#endif--#ifdef SIZ_NUM-instance (GSizeSum (a :+: b)) => GSize (a :+: b) where- gsize !n x = n + gsizeSum 0 x-#endif--#ifdef SIZ_MAX-instance (GSizeNxt (a :+: b),GSizeMax (a:+:b)) => GSize (a :+: b) where- gsize !n x = gsizeNxt (gsizeMax x + n) x- {-# INLINE gsize #-}---- Calculate the maximum size of a class constructor (that might be one bit more than the size of some of its constructors)-#ifdef SIZ_MAX_VAL-class GSizeMax (f :: * -> *) where gsizeMax :: f a -> NumBits--instance (GSizeMax f, GSizeMax g) => GSizeMax (f :+: g) where- gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a))- {-# INLINE gsizeMax #-}--instance (GSize a) => GSizeMax (C1 c a) where- {-# INLINE gsizeMax #-}- gsizeMax _ = 0-#endif--#ifdef SIZ_MAX_PROX--- instance (GSizeNxt (a :+: b),GSizeMax (a:+:b)) => GSize (a :+: b) where--- gsize !n x = gsizeNxt (gsizeMax x + n) x--- {-# INLINE gsize #-}----- -- |Calculate size in bits of constructor--- class KnownNat n => GSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits---- instance (GSizeMax (n + 1) a, GSizeMax (n + 1) b, KnownNat n) => GSizeMax n (a :+: b) where--- gsizeMax !n x _ = case x of--- L1 !l -> gsizeMax n l (Proxy :: Proxy (n+1))--- R1 !r -> gsizeMax n r (Proxy :: Proxy (n+1))--- {-# INLINE gsizeMax #-}---- instance (GSize a, KnownNat n) => GSizeMax n (C1 c a) where--- {-# INLINE gsizeMax #-}--- gsizeMax !n !x _ = gsize (constructorSize + n) x--- where--- constructorSize :: NumBits--- constructorSize = fromInteger (natVal (Proxy :: Proxy n))---- class KnownNat (ConsSize f) => GSizeMax (f :: * -> *) where--- gsizeMax :: f a -> NumBits--- gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f)))--type family ConsSize (a :: * -> *) :: Nat where- ConsSize (C1 c a) = 0- ConsSize (x :+: y) = 1 + Max (ConsSize x) (ConsSize y)--type family Max (n :: Nat) (m :: Nat) :: Nat where- Max n m = If (n <=? m) m n--type family If c (t::Nat) (e::Nat) where- If 'True t e = t- If 'False t e = e-#endif---- Calculate the size of a value, not taking in account its constructor-class GSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a -> NumBits--instance (GSizeNxt a, GSizeNxt b) => GSizeNxt (a :+: b) where- gsizeNxt n x = case x of- L1 !l-> gsizeNxt n l- R1 !r-> gsizeNxt n r- {-# INLINE gsizeNxt #-}--instance (GSize a) => GSizeNxt (C1 c a) where- {-# INLINE gsizeNxt #-}- gsizeNxt !n !x = gsize n x-#endif---- Calculate size in bits of constructor--- vs proxy implementation: similar compilation time but much better run times (at least for Tree N, -70%)-class GSizeSum (f :: * -> *) where gsizeSum :: NumBits -> f a -> NumBits--instance (GSizeSum a, GSizeSum b)- => GSizeSum (a :+: b) where- gsizeSum !n x = case x of- L1 !l-> gsizeSum (n+1) l- R1 !r-> gsizeSum (n+1) r- {-# INLINE gsizeSum #-}--instance (GSize a) => GSizeSum (C1 c a) where- {-# INLINE gsizeSum #-}- gsizeSum !n !x = gsize n x----- |Calculate number of constructors-type family NumConstructors (a :: * -> *) :: Nat where- NumConstructors (C1 c a) = 1- NumConstructors (x :+: y) = NumConstructors x + NumConstructors y---unused :: forall a . a-unused = error $ "Now, now, you could not possibly have meant this.."
− src/Data/Flat/Decoder.hs
@@ -1,47 +0,0 @@--- |Strict Decoder-module Data.Flat.Decoder (- strictDecoder,- strictDecoderPart,- Decoded,- DecodeException,- Get,- dByteString,- dLazyByteString,- dShortByteString,- dShortByteString_,- dUTF16,- dUTF8,- decodeArrayWith,- decodeListWith,- dFloat,- dDouble,- dInteger,- dNatural,- dChar,- dBool,- dWord8,- dWord16,- dWord32,- dWord64,- dWord,- dInt8,- dInt16,- dInt32,- dInt64,- dInt,- dBE8,- dBE16,- dBE32,- dBE64,- dBEBits8,- dBEBits16,- dBEBits32,- dBEBits64,- dropBits,-- ConsState(..),consOpen,consClose,consBool,consBits- ) where--import Data.Flat.Decoder.Prim-import Data.Flat.Decoder.Strict-import Data.Flat.Decoder.Types
− src/Data/Flat/Decoder/Prim.hs
@@ -1,391 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |Strict Decoder Primitives-module Data.Flat.Decoder.Prim (- dBool,- dWord8,- dBE8,- dBE16,- dBE32,- dBE64,- dBEBits8,- dBEBits16,- dBEBits32,- dBEBits64,- dropBits,- dFloat,- dDouble,- getChunksInfo,- dByteString_,- dLazyByteString_,- dByteArray_,-- ConsState(..),consOpen,consClose,consBool,consBits- ) where--import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Flat.Decoder.Types-import Data.Flat.Endian-import Data.Flat.Memory-import Data.FloatCast-import Data.Word-import Foreign---- $setup--- >>> :set -XBinaryLiterals--- >>> import Data.Flat.Run---- |A special state, optimised for constructor decoding, consists of:--- The bits to parse, top bit being the first to parse (could use a Word16 instead, no difference in performance)--- The number of decoded bits--- Supports up to 512 constructors (9 bits)-data ConsState =- ConsState {-# UNPACK #-} !Word !Int---- |Switch to constructor decoding--- {-# INLINE consOpen #-}-consOpen :: Get ConsState-consOpen = Get $ \endPtr s -> do- let u = usedBits s- w <- case compare (currPtr s) endPtr of- LT -> do -- two different bytes- w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)- return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16))- EQ -> do- w8 :: Word8 <- peek (currPtr s)- return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8))- GT -> notEnoughSpace endPtr s- return $ GetResult s (ConsState w 0)---- |Switch back to normal decoding--- {-# NOINLINE consClose #-}-consClose :: Int -> Get ()-consClose n = Get $ \endPtr s -> do- let u' = n+usedBits s- if u' < 8- then return $ GetResult (s {usedBits=u'}) ()- else if currPtr s >= endPtr- then notEnoughSpace endPtr s- else return $ GetResult (s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}) ()-- {- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s- dropBits8 s n =- let u' = n+usedBits s- in if u' < 8- then s {usedBits=u'}- else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}- -}-- --ensureBits endPtr s n- --return $ GetResult (dropBits8 s n) ()---- |Decode a single bit-consBool :: ConsState -> (ConsState,Bool)-consBool cs = (0/=) <$> consBits cs 1---- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w)---- |Decode from 1 to 3 bits--- This could read more bits that are available, but it doesn't matter, errors will be checked in consClose-consBits :: ConsState -> Int -> (ConsState, Word)-consBits cs 3 = consBits_ cs 3 7-consBits cs 2 = consBits_ cs 2 3-consBits cs 1 = consBits_ cs 1 1-consBits _ _ = error "unsupported"--consBits_ :: ConsState -> Int -> Word -> (ConsState, Word)---- Different decoding primitives--- All with equivalent performance--- #define CONS_ROT--- #define CONS_SHL-#define CONS_STA--#ifdef CONS_ROT-consBits_ (ConsState w usedBits) numBits mask =- let usedBits' = numBits+usedBits- w' = w `rotateL` numBits -- compiles to an or+shiftl+shiftr- in (ConsState w' usedBits',w' .&. mask)-#endif--#ifdef CONS_SHL-consBits_ (ConsState w usedBits) numBits mask =- let usedBits' = numBits+usedBits- w' = w `unsafeShiftL` numBits- in (ConsState w' usedBits', (w `shR` (wordSize - numBits)) .&. mask)-#endif--#ifdef CONS_STA-consBits_ (ConsState w usedBits) numBits mask =- let usedBits' = numBits+usedBits- in (ConsState w usedBits', (w `shR` (wordSize - usedBits')) .&. mask)-#endif--wordSize :: Int-wordSize = finiteBitSize (0 :: Word)--{-# INLINE ensureBits #-}--- |Ensure that the specified number of bits is available-ensureBits :: Ptr Word8 -> S -> Int -> IO ()-ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s--{-# INLINE dropBits #-}--- |Drop the specified number of bits-dropBits :: Int -> Get ()-dropBits n- | n > 0 = Get $ \endPtr s -> do- ensureBits endPtr s n- return $ GetResult (dropBits_ s n) ()- | n == 0 = return ()- | otherwise = error $ unwords ["dropBits",show n]--{-# INLINE dropBits_ #-}-dropBits_ :: S -> Int -> S-dropBits_ s n =- let (bytes,bits) = (n+usedBits s) `divMod` 8- -- let- -- n' = n+usedBits s- -- bytes = n' `shR` 3- -- bits = n' .|. 7- in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}--{-# INLINE dBool #-}--- {-# INLINE dBool #-} -- INLINE Massively increases compilation time and decreases run time by a third--- |Decode a boolean-dBool :: Get Bool-dBool = Get $ \endPtr s ->- if currPtr s >= endPtr- then notEnoughSpace endPtr s- else do- !w <- peek (currPtr s)- let !b = 0 /= (w .&. (128 `shR` usedBits s))- let !s' = if usedBits s == 7- then s { currPtr = currPtr s `plusPtr` 1, usedBits = 0 }- else s { usedBits = usedBits s + 1 }- return $ GetResult s' b---{-# INLINE dBEBits8 #-}--- |Return the n most significant bits (up to maximum of 8)------ The bits are returned right shifted:--- >>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111--- True-dBEBits8 :: Int -> Get Word8-dBEBits8 n = Get $ \endPtr s -> do- ensureBits endPtr s n- take8 s n--{-# INLINE dBEBits16 #-}--- |Return the n most significant bits (up to maximum of 16)--- The bits are returned right shifted.-dBEBits16 :: Int -> Get Word16-dBEBits16 n = Get $ \endPtr s -> do- ensureBits endPtr s n- takeN n s--{-# INLINE dBEBits32 #-}--- |Return the n most significant bits (up to maximum of 8)--- The bits are returned right shifted.-dBEBits32 :: Int -> Get Word32-dBEBits32 n = Get $ \endPtr s -> do- ensureBits endPtr s n- takeN n s--{-# INLINE dBEBits64 #-}--- |Return the n most significant bits (up to maximum of 8)--- The bits are returned right shifted.-dBEBits64 :: Int -> Get Word64-dBEBits64 n = Get $ \endPtr s -> do- ensureBits endPtr s n- takeN n s---- {-# INLINE take8 #-}--- take8 :: Int -> S -> IO (GetResult Word8)--- take8 n s--- | n == 0 = return $ GetResult s 0---- -- all bits in the same byte--- | n <= 8 - usedBits s = do--- w <- peek (currPtr s)--- let (bytes,bits) = (n+usedBits s) `divMod` 8--- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) ((w `unsafeShiftL` usedBits s) `shR` (8 - n))---- -- two different bytes--- | n <= 8 = do--- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)--- return $ GetResult (S {currPtr=currPtr s `plusPtr` 1,usedBits=(usedBits s + n) `mod` 8}) (fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n))---- | otherwise = error $ unwords ["take8: cannot take",show n,"bits"]--{-# INLINE take8 #-}-take8 :: S -> Int -> IO (GetResult Word8)--- take8 s n = GetResult (dropBits_ s n) <$> read8 s n-take8 s n = GetResult (dropBits8 s n) <$> read8 s n- where- --{-# INLINE read8 #-}- read8 :: S -> Int -> IO Word8- read8 s n | n >=0 && n <=8 =- if n <= 8 - usedBits s- then do -- all bits in the same byte- w <- peek (currPtr s)- return $ (w `unsafeShiftL` usedBits s) `shR` (8 - n)- else do -- two different bytes- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)- return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)- | otherwise = error $ unwords ["read8: cannot read",show n,"bits"]- -- {-# INLINE dropBits8 #-}- -- -- Assume n <= 8- dropBits8 :: S -> Int -> S- dropBits8 s n =- let u' = n+usedBits s- in if u' < 8- then s {usedBits=u'}- else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}---{-# INLINE takeN #-}-takeN :: (Num a, Bits a) => Int -> S -> IO (GetResult a)-takeN n s = read s 0 (n - (n `min` 8)) n- where- read s r sh n | n <=0 = return $ GetResult s r- | otherwise = do- let m = n `min` 8- GetResult s' b <- take8 s m- read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8)---- takeN n = Get $ \endPtr s -> do--- ensureBits endPtr s n--- let (bytes,bits) = (n+usedBits s) `divMod` 8--- r <- case bytes of--- 0 -> do--- w <- peek (currPtr s)--- return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `shR` (8 - n))--- 1 -> do--- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)--- return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `shR` (16 - n)--- 2 -> do--- let r = 0--- w1 <- fromIntegral <$> r8 s--- w2 <- fromIntegral <$> r16 s--- w1--- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r---- r8 s = peek (currPtr s)--- r16 s = toBE16 <$> peek (castPtr $ currPtr s)---- |Return the 8 most significant bits (same as dBE8)-dWord8 :: Get Word8-dWord8 = dBE8--{-# INLINE dBE8 #-}--- |Return the 8 most significant bits-dBE8 :: Get Word8-dBE8 = Get $ \endPtr s -> do- ensureBits endPtr s 8- !w1 <- peek (currPtr s)- !w <- if usedBits s == 0- then return w1- else do- !w2 <- peek (currPtr s `plusPtr` 1)- return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `shR` (8-usedBits s))- return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w--{-# INLINE dBE16 #-}--- |Return the 16 most significant bits-dBE16 :: Get Word16-dBE16 = Get $ \endPtr s -> do- ensureBits endPtr s 16- !w1 <- toBE16 <$> peek (castPtr $ currPtr s)- !w <- if usedBits s == 0- then return w1- else do- !(w2::Word8) <- peek (currPtr s `plusPtr` 2)- return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `shR` (8-usedBits s))- return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w--{-# INLINE dBE32 #-}--- |Return the 32 most significant bits-dBE32 :: Get Word32-dBE32 = Get $ \endPtr s -> do- ensureBits endPtr s 32- !w1 <- toBE32 <$> peek (castPtr $ currPtr s)- !w <- if usedBits s == 0- then return w1- else do- !(w2::Word8) <- peek (currPtr s `plusPtr` 4)- return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `shR` (8-usedBits s))- return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w--{-# INLINE dBE64 #-}--- |Return the 64 most significant bits-dBE64 :: Get Word64-dBE64 = Get $ \endPtr s -> do- ensureBits endPtr s 64- -- !w1 <- toBE64 <$> peek (castPtr $ currPtr s)- !w1 <- toBE64 <$> peek64 (castPtr $ currPtr s)- !w <- if usedBits s == 0- then return w1- else do- !(w2::Word8) <- peek (currPtr s `plusPtr` 8)- return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `shR` (8-usedBits s))- return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w- where- -- {-# INLINE peek64 #-}- peek64 :: Ptr Word64 -> IO Word64- peek64 ptr = fix64 <$> peek ptr--{-# INLINE dFloat #-}--- |Decode a Float-dFloat :: Get Float-dFloat = wordToFloat <$> dBE32--{-# INLINE dDouble #-}--- |Decode a Double-dDouble :: Get Double-dDouble = wordToDouble <$> dBE64---- |Decode a Lazy ByteString-dLazyByteString_ :: Get L.ByteString-dLazyByteString_ = L.fromStrict <$> dByteString_---- |Decode a ByteString-dByteString_ :: Get B.ByteString-dByteString_ = chunksToByteString <$> getChunksInfo---- |Decode a ByteArray and its length-dByteArray_ :: Get (ByteArray,Int)-dByteArray_ = chunksToByteArray <$> getChunksInfo---- |Decode an Array (a list of chunks up to 255 bytes long)--- returning the pointer to the first data byte and a list of chunk sizes-getChunksInfo :: Get (Ptr Word8, [Int])-getChunksInfo = Get $ \endPtr s -> do-- let getChunks srcPtr l = do- ensureBits endPtr s 8- n <- fromIntegral <$> peek srcPtr- if n==0- then return (srcPtr `plusPtr` 1,l [])- else do- ensureBits endPtr s ((n+1)*8)- getChunks (srcPtr `plusPtr` (n+1)) (l . (n:))-- when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0"- (currPtr',ns) <- getChunks (currPtr s) id- return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns)---- Fix for ghcjs bug: https://github.com/ghcjs/ghcjs/issues/706--- TODO: verify if actually needed here and if also needed in encoder-{-# INLINE shR #-}-shR :: Bits a => a -> Int -> a-#ifdef ghcjs_HOST_OS-shR val 0 = val-shR val n = shift val (-n)-#else-shR = unsafeShiftR-#endif
− src/Data/Flat/Decoder/Strict.hs
@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--- |Strict Decoder-module Data.Flat.Decoder.Strict (- decodeArrayWith,- decodeListWith,- dByteString,- dLazyByteString,- dShortByteString,- dShortByteString_,- dUTF16,- dUTF8,- dInteger,- dNatural,- dChar,- dWord8,- dWord16,- dWord32,- dWord64,- dWord,- dInt8,- dInt16,- dInt32,- dInt64,- dInt,- ) where--import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Short as SBS-import qualified Data.ByteString.Short.Internal as SBS-import qualified Data.DList as DL-import Data.Flat.Decoder.Prim-import Data.Flat.Decoder.Types-import Data.Int-import Data.Primitive.ByteArray-import qualified Data.Text as T-import qualified Data.Text.Array as TA-import qualified Data.Text.Encoding as T-import qualified Data.Text.Internal as T-import Data.Word-import Data.ZigZag-import GHC.Base (unsafeChr)-import Numeric.Natural--#include "MachDeps.h"---{-# INLINE decodeListWith #-}-decodeListWith :: Get a -> Get [a]-decodeListWith dec = go- where- go = do- b <- dBool- if b- then (:) <$> dec <*> go- else return []--decodeArrayWith :: Get a -> Get [a]-decodeArrayWith dec = DL.toList <$> getAsL_ dec---- TODO: test if it would it be faster with DList.unfoldr :: (b -> Maybe (a, b)) -> b -> Data.DList.DList a--- getAsL_ :: Flat a => Get (DL.DList a)-getAsL_ :: Get a -> Get (DL.DList a)-getAsL_ dec = do- tag <- dWord8- case tag of- 0 -> return DL.empty- _ -> do- h <- gets tag- t <- getAsL_ dec- return (DL.append h t)-- where- gets 0 = return DL.empty- gets n = DL.cons <$> dec <*> gets (n-1)--{-# INLINE dNatural #-}-dNatural :: Get Natural-dNatural = fromInteger <$> dUnsigned--{-# INLINE dInteger #-}-dInteger :: Get Integer-dInteger = zzDecodeInteger <$> (dUnsigned::Get Integer)--{-# INLINE dWord #-}-{-# INLINE dInt #-}-dWord :: Get Word-dInt :: Get Int--#if WORD_SIZE_IN_BITS == 64-dWord = (fromIntegral :: Word64 -> Word) <$> dWord64-dInt = (fromIntegral :: Int64 -> Int) <$> dInt64--#elif WORD_SIZE_IN_BITS == 32-dWord = (fromIntegral :: Word32 -> Word) <$> dWord32-dInt = (fromIntegral :: Int32 -> Int) <$> dInt32--#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif--{-# INLINE dInt8 #-}-dInt8 :: Get Int8-dInt8 = zzDecode8 <$> dWord8--{-# INLINE dInt16 #-}-dInt16 :: Get Int16-dInt16 = zzDecode16 <$> dWord16--{-# INLINE dInt32 #-}-dInt32 :: Get Int32-dInt32 = zzDecode32 <$> dWord32--{-# INLINE dInt64 #-}-dInt64 :: Get Int64-dInt64 = zzDecode64 <$> dWord64---- {-# INLINE dWord16 #-}-dWord16 :: Get Word16-dWord16 = wordStep 0 (wordStep 7 (lastStep 14)) 0---- {-# INLINE dWord32 #-}-dWord32 :: Get Word32-dWord32 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (lastStep 28)))) 0---- {-# INLINE dWord64 #-}-dWord64 :: Get Word64-dWord64 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (wordStep 28 (wordStep 35 (wordStep 42 (wordStep 49 (wordStep 56 (wordStep 63 (wordStep 70 (lastStep 77))))))))))) 0---{-# INLINE dChar #-}-dChar :: Get Char--- dChar = chr . fromIntegral <$> dWord32---- Not really faster than the simpler version above-dChar = charStep 0 (charStep 7 (lastCharStep 14)) 0--{-# INLINE charStep #-}-charStep :: Int -> (Int -> Get Char) -> Int -> Get Char-charStep !shl !cont !n = do- !tw <- fromIntegral <$> dWord8- let !w = tw .&. 127- let !v = n .|. (w `shift` shl)- if tw == w- then return $ unsafeChr v- else cont v--{-# INLINE lastCharStep #-}-lastCharStep :: Int -> Int -> Get Char-lastCharStep !shl !n = do- !tw <- fromIntegral <$> dWord8- let !w = tw .&. 127- let !v = n .|. (w `shift` shl)- if tw == w- then if v > 0x10FFFF- then charErr v- else return $ unsafeChr v- else charErr v--charErr :: (Show a1, Monad m) => a1 -> m a-charErr v = fail $ concat ["Unexpected extra byte or non unicode char",show v]--{-# INLINE wordStep #-}-wordStep- :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a-wordStep shl k n = do- tw <- fromIntegral <$> dWord8- let w = tw .&. 127- let v = n .|. (w `shift` shl)- if tw == w- then return v- --else oneShot k v- else k v--{-# INLINE lastStep #-}-lastStep :: (FiniteBits b, Show b, Num b) => Int -> b -> Get b-lastStep shl n = do- tw <- fromIntegral <$> dWord8- let w = tw .&. 127- let v = n .|. (w `shift` shl)- if tw == w- then if countLeadingZeros w < shl- then wordErr v- else return v- else wordErr v--wordErr :: (Show a1, Monad m) => a1 -> m a-wordErr v = fail $ concat ["Unexpected extra byte in unsigned integer",show v]---- {-# INLINE dUnsigned #-}-dUnsigned :: (Num b, Bits b) => Get b-dUnsigned = do- (v,shl) <- dUnsigned_ 0 0- maybe (return v) (\s -> if shl>= s then fail "Unexpected extra data in unsigned integer" else return v) $ bitSizeMaybe v---- {-# INLINE dUnsigned_ #-}-dUnsigned_ :: (Bits t, Num t) => Int -> t -> Get (t, Int)-dUnsigned_ shl n = do- tw <- dWord8- let w = tw .&. 127- let v = n .|. (fromIntegral w `shift` shl)- if tw == w- then return (v,shl)- else dUnsigned_ (shl+7) v----encode = encode . blob UTF8Encoding . L.fromStrict . T.encodeUtf8---decode = T.decodeUtf8 . L.toStrict . (unblob :: BLOB UTF8Encoding -> L.ByteString) <$> decode---- BLOB UTF16Encoding-dUTF16 :: Get T.Text-dUTF16 = do- _ <- dFiller- -- Checked decoding- -- T.decodeUtf16LE <$> dByteString_- -- Unchecked decoding- (ByteArray array,lengthInBytes) <- dByteArray_- return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2))--dUTF8 :: Get T.Text-dUTF8 = do- _ <- dFiller- T.decodeUtf8 <$> dByteString_--dFiller :: Get ()-dFiller = do- tag <- dBool- case tag of- False -> dFiller- True -> return ()--dLazyByteString :: Get L.ByteString-dLazyByteString = dFiller >> dLazyByteString_--dShortByteString :: Get SBS.ShortByteString-dShortByteString = dFiller >> dShortByteString_--dShortByteString_ :: Get SBS.ShortByteString-dShortByteString_ = do- (ByteArray array,_) <- dByteArray_- return $ SBS.SBS array--dByteString :: Get B.ByteString-dByteString = dFiller >> dByteString_
− src/Data/Flat/Decoder/Types.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}---- |Strict Decoder Types-module Data.Flat.Decoder.Types (- strictDecoder,- strictDecoderPart,- Get(..),- S(..),- GetResult(..),- Decoded,- DecodeException,- notEnoughSpace,- tooMuchSpace,- badEncoding,- ) where--import Control.DeepSeq-import Control.Exception-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as BS-import Data.Word-import System.IO.Unsafe-import Foreign--strictDecoder :: Get a -> B.ByteString -> Either DecodeException a-strictDecoder get bs = strictDecoder_ get bs $ \(GetResult s'@(S ptr' o') a) endPtr ->- if ptr' /= endPtr || o' /= 0- then tooMuchSpace endPtr s'- else return a--strictDecoderPart :: Get a -> B.ByteString -> Either DecodeException a-strictDecoderPart get bs = strictDecoder_ get bs $ \(GetResult _ a) _ -> return a--strictDecoder_- :: Exception e =>- Get a1- -> BS.ByteString -> (GetResult a1 -> Ptr b -> IO a) -> Either e a-strictDecoder_ get (BS.PS base off len) check = unsafePerformIO . try $- withForeignPtr base $ \base0 ->- let ptr = base0 `plusPtr` off- endPtr = ptr `plusPtr` len- in do- res <- runGet get endPtr (S ptr 0)- check res endPtr---- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits)--- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $--- withForeignPtr base $ \base0 ->--- let ptr = base0 `plusPtr` off--- endPtr = ptr `plusPtr` len--- in do--- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0)--- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o')---- |Decoder monad-newtype Get a = Get {runGet ::- Ptr Word8 -- End Ptr- -> S- -> IO (GetResult a)- } -- deriving (Functor)---- Seems to give better performance than the derived version -instance Functor Get where- fmap f g = Get $ \end s -> do- GetResult s' a <- runGet g end s- return $ GetResult s' (f a) - {-# INLINE fmap #-}---- Is this correct?-instance NFData (Get a) where rnf !_ = ()--instance Show (Get a) where show _ = "Get"--instance Applicative Get where- pure x = Get (\_ ptr -> return $ GetResult ptr x)- {-# INLINE pure #-}-- Get f <*> Get g = Get $ \end ptr1 -> do- GetResult ptr2 f' <- f end ptr1- GetResult ptr3 g' <- g end ptr2- return $ GetResult ptr3 (f' g')- {-# INLINE (<*>) #-}-- Get f *> Get g = Get $ \end ptr1 -> do- GetResult ptr2 _ <- f end ptr1- g end ptr2- {-# INLINE (*>) #-}--instance Monad Get where- return = pure- {-# INLINE return #-}-- (>>) = (*>)- {-# INLINE (>>) #-}-- Get x >>= f = Get $ \end s -> do- GetResult s' x' <- x end s- runGet (f x') end s'- {-# INLINE (>>=) #-}-- fail msg = Get $ \end s -> badEncoding end s msg- {-# INLINE fail #-}---- |Decoder state-data S =- S- { currPtr :: {-# UNPACK #-} !(Ptr Word8)- , usedBits :: {-# UNPACK #-} !Int- } deriving (Show,Eq,Ord)--data GetResult a = GetResult {-# UNPACK #-} !S !a deriving Functor---- |A decoded value-type Decoded a = Either DecodeException a---- |An exception during decoding-data DecodeException = NotEnoughSpace Env- | TooMuchSpace Env- | BadEncoding Env String- deriving (Show,Eq,Ord)--type Env = (Ptr Word8,S)--notEnoughSpace :: Ptr Word8 -> S -> IO a-notEnoughSpace endPtr s = throwIO $ NotEnoughSpace (endPtr,s)--tooMuchSpace :: Ptr Word8 -> S -> IO a-tooMuchSpace endPtr s = throwIO $ TooMuchSpace (endPtr,s)--badEncoding :: Ptr Word8 -> S -> String -> IO a-badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg--instance Exception DecodeException--
− src/Data/Flat/Encoder.hs
@@ -1,68 +0,0 @@-module Data.Flat.Encoder (- Encoding,- (<>),- NumBits,- encodersS,- mempty,- strictEncoder,- eTrueF,- eFalseF,- eFloat,- eDouble,- eInteger,- eNatural,- eWord16,- eWord32,- eWord64,- eWord8,- eBits,- eBits16,- eFiller,- eBool,- eTrue,- eFalse,- eBytes,- eUTF16,- eLazyBytes,- eShortBytes,- eInt,- eInt8,- eInt16,- eInt32,- eInt64,- eWord,- eChar,- encodeArrayWith,- encodeListWith,- Size,- arrayBits,- sWord,- sWord8,- sWord16,- sWord32,- sWord64,- sInt,- sInt8,- sInt16,- sInt32,- sInt64,- sNatural,- sInteger,- sFloat,- sDouble,- sChar,- sBytes,- sLazyBytes,- sShortBytes,- sUTF16,- sFillerMax,- sBool,- sUTF8Max,- eUTF8,- ) where--import Data.Flat.Encoder.Prim-import Data.Flat.Encoder.Size(arrayBits)-import Data.Flat.Encoder.Strict-import Data.Flat.Encoder.Types-import Data.Monoid((<>))
− src/Data/Flat/Encoder/Prim.hs
@@ -1,402 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE UnboxedTuples #-}--- |Encoding Primitives-module Data.Flat.Encoder.Prim (- eBits16F,- eBitsF,- eFloatF,- eDoubleF,- eUTF16F,- eUTF8F,- eCharF,- eNaturalF,- eIntegerF,- eInt64F,- eInt32F,- eIntF,- eInt16F,- eInt8F,- eWordF,- eWord64F,- eWord32F,- eWord16F,- eBytesF,- eLazyBytesF,- eShortBytesF,- eWord8F,- eFillerF,- eBoolF,- eTrueF,- eFalseF,- varWordF,- w7l,- -- * Exported for testing only- eWord32BEF,eWord64BEF,eWord32E,eWord64E- ) where--import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L-import qualified Data.ByteString.Short.Internal as SBS-import Data.Char-import Data.Flat.Encoder.Types-import Data.Flat.Endian-import Data.Flat.Memory-import Data.Flat.Types-import Data.FloatCast-import Data.Primitive.ByteArray-import qualified Data.Text as T-import qualified Data.Text.Array as TA-import qualified Data.Text.Encoding as T-import qualified Data.Text.Internal as T-import Data.ZigZag-import Foreign---- import Debug.Trace-#include "MachDeps.h"---- traceShowId :: a -> a--- traceShowId = id--{-# INLINE eFloatF #-}-eFloatF :: Float -> Prim-eFloatF = eWord32BEF . floatToWord--{-# INLINE eDoubleF #-}-eDoubleF :: Double -> Prim-eDoubleF = eWord64BEF . doubleToWord--{-# INLINE eWord64BEF #-}-eWord64BEF :: Word64 -> Prim-eWord64BEF = eWord64E toBE64--{-# INLINE eWord32BEF #-}-eWord32BEF :: Word32 -> Prim-eWord32BEF = eWord32E toBE32--{-# INLINE eCharF #-}-eCharF :: Char -> Prim-eCharF = eWord32F . fromIntegral . ord--{-# INLINE eWordF #-}-eWordF :: Word -> Prim--{-# INLINE eIntF #-}-eIntF :: Int -> Prim--#if WORD_SIZE_IN_BITS == 64-eWordF = eWord64F . (fromIntegral :: Word -> Word64)-eIntF = eInt64F . (fromIntegral :: Int -> Int64)-#elif WORD_SIZE_IN_BITS == 32-eWordF = eWord32F . (fromIntegral :: Word -> Word32)-eIntF = eInt32F . (fromIntegral :: Int -> Int32)-#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif--{-# INLINE eInt8F #-}-eInt8F :: Int8 -> Prim-eInt8F = eWord8F . zzEncode--{-# INLINE eInt16F #-}-eInt16F :: Int16 -> Prim-eInt16F = eWord16F . zzEncode--{-# INLINE eInt32F #-}-eInt32F :: Int32 -> Prim-eInt32F = eWord32F . zzEncode--{-# INLINE eInt64F #-}-eInt64F :: Int64 -> Prim-eInt64F = eWord64F . zzEncode--{-# INLINE eIntegerF #-}-eIntegerF :: Integer -> Prim-eIntegerF = eIntegralF . zzEncodeInteger--{-# INLINE eNaturalF #-}-eNaturalF :: Natural -> Prim-eNaturalF = eIntegralF . toInteger--{-# INLINE eIntegralF #-}-eIntegralF :: (Bits t, Integral t) => t -> Prim-eIntegralF t = let vs = w7l t- in eIntegralW vs--w7l :: (Bits t, Integral t) => t -> [Word8]-w7l t = let l = low7 t- t' = t `unsafeShiftR` 7- in if t' == 0- then [l]- else w7 l : w7l t'- where- {-# INLINE w7 #-}- --lowByte :: (Bits t, Num t) => t -> Word8- w7 :: Word8 -> Word8- w7 l = l .|. 0x80---- Encode as data NEList = Elem Word7 | Cons Word7 List-{-# INLINE eIntegralW #-}-eIntegralW :: [Word8] -> Prim-eIntegralW vs s@(S op _ o) | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0)- | otherwise = foldM (flip eWord8F) s vs---{-# INLINE eWord8F #-}-eWord8F :: Word8 -> Prim-eWord8F t s@(S op _ o) | o==0 = pokeWord op t- | otherwise = pokeByteUnaligned t s--{-# INLINE eWord32E #-}-eWord32E :: (Word32 -> Word32) -> Word32 -> Prim-eWord32E conv t (S op w o) | o==0 = pokeW conv op t >> skipBytes op 4- | otherwise = pokeW conv op (asWord32 w `unsafeShiftL` 24 .|. t `unsafeShiftR` o) >> return (S (plusPtr op 4) (asWord8 t `unsafeShiftL` (8-o)) o)--{-# INLINE eWord64E #-}-eWord64E :: (Word64 -> Word64) -> Word64 -> Prim-eWord64E conv t (S op w o) | o==0 = poke64 conv op t >> skipBytes op 8- | otherwise = poke64 conv op (asWord64 w `unsafeShiftL` 56 .|. t `unsafeShiftR` o) >> return (S (plusPtr op 8) (asWord8 t `unsafeShiftL` (8-o)) o)--{-# INLINE eWord16F #-}-eWord16F :: Word16 -> Prim-eWord16F = varWordF--{-# INLINE eWord32F #-}-eWord32F :: Word32 -> Prim-eWord32F = varWordF--{-# INLINE eWord64F #-}-eWord64F :: Word64 -> Prim-eWord64F = varWordF--{-# INLINE varWordF #-}-varWordF :: (Bits t, Integral t) => t -> Prim-varWordF t s@(S _ _ o) | o == 0 = varWord pokeByteAligned t s- | otherwise = varWord pokeByteUnaligned t s--{-# INLINE varWord #-}-varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim-varWord writeByte t s- | t < 128 = writeByte (fromIntegral t) s- | t < 16384 = varWord2_ writeByte t s- | t < 2097152 = varWord3_ writeByte t s- | otherwise = varWordN_ writeByte t s- where- {-# INLINE varWord2_ #-}- -- TODO: optimise, using a single Write16?- varWord2_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `unsafeShiftR` 7) .&. 0x7F)-- {-# INLINE varWord3_ #-}- varWord3_ writeByte t s = writeByte (fromIntegral t .|. 0x80) s >>= writeByte (fromIntegral (t `unsafeShiftR` 7) .|. 0x80) >>= writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F)---- {-# INLINE varWordN #-}-varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim-varWordN_ writeByte = go- where- go !v !st =- let !l = low7 v- !v' = v `unsafeShiftR` 7- in if v' == 0- then writeByte l st- else writeByte (l .|. 0x80) st >>= go v'--{-# INLINE low7 #-}-low7 :: (Integral a) => a -> Word8-low7 t = fromIntegral t .&. 0x7F---- PROB: encodeUtf8 calls a C primitive, not compatible with GHCJS-eUTF8F :: T.Text -> Prim-eUTF8F = eBytesF . T.encodeUtf8--eUTF16F :: T.Text -> Prim-eUTF16F t = eFillerF >=> eUTF16F_ t- where- eUTF16F_ !(T.Text (TA.Array array) w16Off w16Len) s = writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s)--eLazyBytesF :: L.ByteString -> Prim-eLazyBytesF bs = eFillerF >=> \s -> write bs (nextPtr s)- where- -- Single copy- write lbs op = do- case lbs of- L.Chunk h t -> writeBS h op >>= write t- L.Empty -> pokeWord op 0--{-# INLINE eShortBytesF #-}-eShortBytesF :: SBS.ShortByteString -> Prim-eShortBytesF bs = eFillerF >=> eShortBytesF_ bs--eShortBytesF_ :: SBS.ShortByteString -> Prim-eShortBytesF_ bs@(SBS.SBS arr) = \(S op _ 0) -> writeArray arr 0 (SBS.length bs) op---- data Array a = Array0 | Array1 a ... | Array255 ...-writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S-writeArray arr soff slen sop = do- op' <- go soff slen sop- pokeWord op' 0- where- go !off !len !op- | len == 0 = return op- | otherwise =- let l = min 255 len- in pokeWord' op (fromIntegral l) >>=- pokeByteArray arr off l >>=- go (off+l) (len - l)--eBytesF :: B.ByteString -> Prim-eBytesF bs = eFillerF >=> eBytesF_- where- eBytesF_ s = do- op' <- writeBS bs (nextPtr s)- pokeWord op' 0----- |Encode up to 9 bits-{-# INLINE eBits16F #-}-eBits16F :: NumBits -> Word16 -> Prim---eBits16F numBits code | numBits >8 = eBitsF (numBits-8) (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF 8 (fromIntegral code)--- eBits16F _ _ = eFalseF-eBits16F 9 code = eBitsF 1 (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF_ 8 (fromIntegral code)-eBits16F numBits code = eBitsF numBits (fromIntegral code)---- |Encode up to 8 bits.-{-# INLINE eBitsF #-}-eBitsF :: NumBits -> Word8 -> Prim-eBitsF 1 0 = eFalseF-eBitsF 1 1 = eTrueF-eBitsF 2 0 = eFalseF >=> eFalseF-eBitsF 2 1 = eFalseF >=> eTrueF-eBitsF 2 2 = eTrueF >=> eFalseF-eBitsF 2 3 = eTrueF >=> eTrueF-eBitsF n t = eBitsF_ n t--{--eBits Example:-Before:-n = 6-t = 00.101011-o = 3-w = 111.00000--After:-[ptr] = w(111)t(10101)-w' = t(1)0000000-o'= 1--o'=3+6=9-f = 8-9 = -1-o'' = 1-8-o''=7--if n=8,o=3:-o'=11-f=8-11=-3-o''=3-8-o''=5--}--- {-# NOINLINE eBitsF_ #-}-eBitsF_ :: NumBits -> Word8 -> Prim-eBitsF_ n t = \(S op w o) ->- let o' = o + n -- used bits- f = 8 - o' -- remaining free bits- in if | f > 0 -> return $ S op (w .|. (t `unsafeShiftL` f)) o'- | f == 0 -> pokeWord op (w .|. t)- | otherwise -> let o'' = -f- in poke op (w .|. (t `unsafeShiftR` o'')) >> return (S (plusPtr op 1) (t `unsafeShiftL` (8-o'')) o'')---{-# INLINE eBoolF #-}-eBoolF :: Bool -> Prim-eBoolF False = eFalseF-eBoolF True = eTrueF--{-# INLINE eTrueF #-}-eTrueF :: Prim-eTrueF (S op w o) | o == 7 = pokeWord op (w .|. 1)- | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o+1))--{-# INLINE eFalseF #-}-eFalseF :: Prim-eFalseF (S op w o) | o == 7 = pokeWord op w- | otherwise = return (S op w (o+1))--{-# INLINE eFillerF #-}-eFillerF :: Prim-eFillerF (S op w _) = pokeWord op (w .|. 1)---- {-# INLINE poke16 #-}--- TODO TEST--- poke16 :: Word16 -> Prim--- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2--{-# INLINE pokeByteUnaligned #-}-pokeByteUnaligned :: Word8 -> Prim-pokeByteUnaligned t (S op w o) = poke op (w .|. (t `unsafeShiftR` o)) >> return (S (plusPtr op 1) (t `unsafeShiftL` (8-o)) o)--{-# INLINE pokeByteAligned #-}-pokeByteAligned :: Word8 -> Prim-pokeByteAligned t (S op _ _) = pokeWord op t--{-# INLINE pokeWord #-}-pokeWord :: Storable a => Ptr a -> a -> IO S-pokeWord op w = poke op w >> skipByte op--{-# INLINE pokeWord' #-}-pokeWord' :: Storable a => Ptr a -> a -> IO (Ptr b)-pokeWord' op w = poke op w >> return (plusPtr op 1)--{-# INLINE pokeW #-}-pokeW :: Storable a => (t -> a) -> Ptr a1 -> t -> IO ()-pokeW conv op t = poke (castPtr op) (conv t)--{-# INLINE poke64 #-}-poke64 :: (t -> Word64) -> Ptr a -> t -> IO ()-poke64 conv op t = poke (castPtr op) (fix64 . conv $ t)--{-# INLINE skipByte #-}-skipByte :: Monad m => Ptr a -> m S-skipByte op = return (S (plusPtr op 1) 0 0)--{-# INLINE skipBytes #-}-skipBytes :: Monad m => Ptr a -> Int -> m S-skipBytes op n = return (S (plusPtr op n) 0 0)----{-# INLINE nextByteW #-}---nextByteW op w = return (S (plusPtr op 1) 0 0)--writeBS :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)-writeBS bs op -- @(BS.PS foreignPointer sourceOffset sourceLength) op- | B.length bs == 0 = return op- | otherwise =- let (h, t) = B.splitAt 255 bs- in pokeWord' op (fromIntegral $ B.length h :: Word8) >>= pokeByteString h >>= writeBS t-- -- 2X slower (why?)- -- withForeignPtr foreignPointer goS- -- where- -- goS sourcePointer = go op (sourcePointer `plusPtr` sourceOffset) sourceLength- -- where- -- go !op !off !len | len == 0 = return op- -- | otherwise = do- -- let l = min 255 len- -- op' <- pokeWord' op (fromIntegral l)- -- BS.memcpy op' off l- -- go (op' `plusPtr` l) (off `plusPtr` l) (len-l)--{-# INLINE asWord64 #-}-asWord64 :: Integral a => a -> Word64-asWord64 = fromIntegral--{-# INLINE asWord32 #-}-asWord32 :: Integral a => a -> Word32-asWord32 = fromIntegral--{-# INLINE asWord8 #-}-asWord8 :: Integral a => a -> Word8-asWord8 = fromIntegral
− src/Data/Flat/Encoder/Size.hs
@@ -1,178 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--- |Primitives to calculate the encoding size of a value-module Data.Flat.Encoder.Size where--import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Short.Internal as SBS-import Data.Char-import Data.Flat.Encoder.Prim (w7l)-import Data.Flat.Encoder.Types-import Data.Flat.Types-import qualified Data.Text as T-import qualified Data.Text.Internal as T-import Data.ZigZag--#include "MachDeps.h"---- A filler can take anything from 1 to 8 bits-sFillerMax :: NumBits-sFillerMax = 8--sBool :: NumBits-sBool = 1--sWord8 :: NumBits-sWord8 = 8--sInt8 :: NumBits-sInt8 = 8--sFloat :: NumBits-sFloat = 32--sDouble :: NumBits-sDouble = 64--{-# INLINE sChar #-}-sChar :: Char -> NumBits-sChar = sWord32 . fromIntegral . ord--sCharMax :: NumBits-sCharMax = 24--{-# INLINE sWord #-}-sWord :: Word -> NumBits--{-# INLINE sInt #-}-sInt :: Int -> NumBits--#if WORD_SIZE_IN_BITS == 64-sWord = sWord64 . fromIntegral-sInt = sInt64 . fromIntegral-#elif WORD_SIZE_IN_BITS == 32-sWord = sWord32 . fromIntegral-sInt = sInt32 . fromIntegral-#else-#error expected WORD_SIZE_IN_BITS to be 32 or 64-#endif---- TODO: optimize ints sizes-{-# INLINE sInt16 #-}-sInt16 :: Int16 -> NumBits-sInt16 = sWord16 . zzEncode--{-# INLINE sInt32 #-}-sInt32 :: Int32 -> NumBits-sInt32 = sWord32 . zzEncode--{-# INLINE sInt64 #-}-sInt64 :: Int64 -> NumBits-sInt64 = sWord64 . zzEncode--{-# INLINE sWord16 #-}-sWord16 :: Word16 -> NumBits-sWord16 w | w < 128 = 8- | w < 16384 = 16- | otherwise = 24--{-# INLINE sWord32 #-}-sWord32 :: Word32 -> NumBits-sWord32 w | w < 128 = 8- | w < 16384 = 16- | w < 2097152 = 24- | w < 268435456 = 32- | otherwise = 40--{-# INLINE sWord64 #-}-sWord64 :: Word64 -> NumBits-sWord64 w | w < 128 = 8- | w < 16384 = 16- | w < 2097152 = 24- | w < 268435456 = 32- | w < 34359738368 = 40- | w < 4398046511104 = 48- | w < 562949953421312 = 56- | w < 72057594037927936 = 64- | w < 9223372036854775808 = 72- | otherwise = 80--{-# INLINE sInteger #-}-sInteger :: Integer -> NumBits-sInteger = sIntegral . zzEncodeInteger--{-# INLINE sNatural #-}-sNatural :: Natural -> NumBits-sNatural = sIntegral . toInteger---- BAD: duplication of work with encoding-{-# INLINE sIntegral #-}-sIntegral :: (Bits t, Integral t) => t -> Int-sIntegral t = let vs = w7l t- in length vs*8----sUTF8 :: T.Text -> NumBits---sUTF8 t = fold---- Wildly pessimistic but fast-{-# INLINE sUTF8Max #-}-sUTF8Max :: Text -> NumBits-sUTF8Max = blobBits . (4*) . T.length--{-# INLINE sUTF16 #-}-sUTF16 :: T.Text -> NumBits-sUTF16 = blobBits . textBytes--{-# INLINE sBytes #-}-sBytes :: B.ByteString -> NumBits-sBytes = blobBits . B.length--{-# INLINE sLazyBytes #-}-sLazyBytes :: L.ByteString -> NumBits-sLazyBytes bs = 16 + L.foldrChunks (\b l -> blkBitsBS b + l) 0 bs--{-# INLINE sShortBytes #-}-sShortBytes :: SBS.ShortByteString -> NumBits-sShortBytes = blobBits . SBS.length---- We are not interested in the number of unicode chars (returned by T.length, an O(n) operation)--- just the number of bytes--- > T.length (T.pack "\x1F600")--- 1--- > textBytes (T.pack "\x1F600")--- 4-{-# INLINE textBytes #-}-textBytes :: T.Text -> Int-textBytes !(T.Text _ _ w16Len) = w16Len * 2--{-# INLINE bitsToBytes #-}-bitsToBytes :: Int -> Int-bitsToBytes = numBlks 8--{-# INLINE numBlks #-}-numBlks :: Integral t => t -> t -> t-numBlks blkSize bits = let (d,m) = bits `divMod` blkSize- in d + (if m==0 then 0 else 1)--{-# INLINE arrayBits #-}-arrayBits :: Int -> NumBits-arrayBits = (8*) . arrayChunks--{-# INLINE arrayChunks #-}-arrayChunks :: Int -> NumBits-arrayChunks = (1+) . numBlks 255--{-# INLINE blobBits #-}-blobBits :: Int -> NumBits-blobBits numBytes = 16 -- initial filler + final 0- + blksBits numBytes--{-# INLINE blkBitsBS #-}-blkBitsBS :: B.ByteString -> NumBits-blkBitsBS = blksBits . B.length--{-# INLINE blksBits #-}-blksBits :: Int -> NumBits-blksBits numBytes = 8*(numBytes + numBlks 255 numBytes)
− src/Data/Flat/Encoder/Strict.hs
@@ -1,246 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |Strict encoder-module Data.Flat.Encoder.Strict where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Flat.Encoder.Prim-import qualified Data.Flat.Encoder.Size as S-import Data.Flat.Encoder.Types-import Data.Flat.Memory-import Data.Flat.Types-import Data.Foldable-import Data.Semigroup (Semigroup (..))---- |Strict encoder-strictEncoder :: NumBits -> Encoding -> B.ByteString-strictEncoder numBits (Encoding op) =- let bufSize = S.bitsToBytes numBits- in fst $ unsafeCreateUptoN' bufSize $ \ptr -> do- (S ptr' 0 0) <- op (S ptr 0 0)- return (ptr' `minusPtr` ptr, ())--newtype Encoding = Encoding { run :: Prim }--instance Show Encoding where show _ = "Encoding"--instance Semigroup Encoding where- {-# INLINE (<>) #-}- (<>) = mappend--instance Monoid Encoding where- {-# INLINE mempty #-}- mempty = Encoding return-- {-# INLINE mappend #-}- -- mappend (Encoding f) (Encoding g) = Encoding (f >=> g)- mappend (Encoding f) (Encoding g) = Encoding m- where m s@(S !_ !_ !_) = do- !s1 <- f s- g s1-- {-# INLINE mconcat #-}- mconcat = foldl' mappend mempty---- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists)-{-# RULES-"encodersSN" forall h t. encodersS (h:t) = h `mappend` encodersS t-"encodersS0" encodersS [] = mempty- #-}--{-# NOINLINE encodersS #-}-encodersS :: [Encoding] -> Encoding--- without the explicit parameter the rules won't fire-encodersS ws = foldl' mappend mempty ws--- encodersS ws = error $ unwords ["encodersS CALLED",show ws]--{-# INLINE encodeListWith #-}--- |Encode as a List-encodeListWith :: (t -> Encoding) -> [t] -> Encoding-encodeListWith enc = go- where- go [] = eFalse- go (x : xs) = eTrue <> enc x <> go xs---- {-# INLINE encodeList #-}--- encodeList :: (Foldable t, Flat a) => t a -> Encoding--- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse---- {-# INLINE encodeList2 #-}--- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding--- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse--{-# INLINE encodeArrayWith #-}--- |Encode as Array-encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding-encodeArrayWith _ [] = eWord8 0-encodeArrayWith f ws = Encoding $ go ws- where- go l s = do- s' <- eWord8F 0 s- (n, s'', l) <- gol l 0 s'- _ <- eWord8F n s- if null l then eWord8F 0 s'' else go l s''-- gol [] !n !s = return (n, s, [])- gol l@(x : xs) !n !s | n == 255 = return (255, s, l)- | otherwise = run (f x) s >>= gol xs (n + 1)---- Encoding primitives-{-# INLINE eChar #-}-{-# INLINE eUTF8 #-}-{-# INLINE eUTF16 #-}-{-# INLINE eNatural #-}-{-# INLINE eFloat #-}-{-# INLINE eDouble #-}-{-# INLINE eInteger #-}-{-# INLINE eInt64 #-}-{-# INLINE eInt32 #-}-{-# INLINE eInt16 #-}-{-# INLINE eInt8 #-}-{-# INLINE eInt #-}-{-# INLINE eWord64 #-}-{-# INLINE eWord32 #-}-{-# INLINE eWord16 #-}-{-# INLINE eWord8 #-}-{-# INLINE eWord #-}-{-# INLINE eBits #-}-{-# INLINE eFiller #-}-{-# INLINE eBool #-}-{-# INLINE eTrue #-}-{-# INLINE eFalse #-}--eChar :: Char -> Encoding-eChar = Encoding . eCharF-eUTF16 :: Text -> Encoding-eUTF16 = Encoding . eUTF16F-eUTF8 :: Text -> Encoding-eUTF8 = Encoding . eUTF8F-eBytes :: B.ByteString -> Encoding-eBytes = Encoding . eBytesF-eLazyBytes :: L.ByteString -> Encoding-eLazyBytes = Encoding . eLazyBytesF-eShortBytes :: ShortByteString -> Encoding-eShortBytes = Encoding . eShortBytesF-eNatural :: Natural -> Encoding-eNatural = Encoding . eNaturalF-eFloat :: Float -> Encoding-eFloat = Encoding . eFloatF-eDouble :: Double -> Encoding-eDouble = Encoding . eDoubleF-eInteger :: Integer -> Encoding-eInteger = Encoding . eIntegerF-eInt64 :: Int64 -> Encoding-eInt64 = Encoding . eInt64F-eInt32 :: Int32 -> Encoding-eInt32 = Encoding . eInt32F-eInt16 :: Int16 -> Encoding-eInt16 = Encoding . eInt16F-eInt8 :: Int8 -> Encoding-eInt8 = Encoding . eInt8F-eInt :: Int -> Encoding-eInt = Encoding . eIntF-eWord64 :: Word64 -> Encoding-eWord64 = Encoding . eWord64F-eWord32 :: Word32 -> Encoding-eWord32 = Encoding . eWord32F-eWord16 :: Word16 -> Encoding-eWord16 = Encoding . eWord16F-eWord8 :: Word8 -> Encoding-eWord8 = Encoding . eWord8F-eWord :: Word -> Encoding-eWord = Encoding . eWordF-eBits16 :: NumBits -> Word16 -> Encoding-eBits16 n f = Encoding $ eBits16F n f-eBits :: NumBits -> Word8 -> Encoding-eBits n f = Encoding $ eBitsF n f-eFiller :: Encoding-eFiller = Encoding eFillerF-eBool :: Bool -> Encoding-eBool = Encoding . eBoolF-eTrue :: Encoding-eTrue = Encoding eTrueF-eFalse :: Encoding-eFalse = Encoding eFalseF---- Size Primitives---- Variable size-{-# INLINE vsize #-}-vsize :: (t -> NumBits) -> t -> NumBits -> NumBits-vsize !f !t !n = f t + n---- Constant size-{-# INLINE csize #-}-csize :: NumBits -> t -> NumBits -> NumBits-csize !n _ !s = n + s--sChar :: Size Char-sChar = vsize S.sChar--sInt64 :: Size Int64-sInt64 = vsize S.sInt64--sInt32 :: Size Int32-sInt32 = vsize S.sInt32--sInt16 :: Size Int16-sInt16 = vsize S.sInt16--sInt8 :: Size Int8-sInt8 = csize S.sInt8--sInt :: Size Int-sInt = vsize S.sInt--sWord64 :: Size Word64-sWord64 = vsize S.sWord64--sWord32 :: Size Word32-sWord32 = vsize S.sWord32--sWord16 :: Size Word16-sWord16 = vsize S.sWord16--sWord8 :: Size Word8-sWord8 = csize S.sWord8--sWord :: Size Word-sWord = vsize S.sWord--sFloat :: Size Float-sFloat = csize S.sFloat--sDouble :: Size Double-sDouble = csize S.sDouble--sBytes :: Size B.ByteString-sBytes = vsize S.sBytes--sLazyBytes :: Size L.ByteString-sLazyBytes = vsize S.sLazyBytes--sShortBytes :: Size ShortByteString-sShortBytes = vsize S.sShortBytes--sNatural :: Size Natural-sNatural = vsize S.sNatural--sInteger :: Size Integer-sInteger = vsize S.sInteger--- sUTF8 = vsize S.sUTF8--sUTF8Max :: Size Text-sUTF8Max = vsize S.sUTF8Max--sUTF16 :: Size Text-sUTF16 = vsize S.sUTF16--sFillerMax :: Size a-sFillerMax = csize S.sFillerMax--sBool :: Size Bool-sBool = csize S.sBool
− src/Data/Flat/Encoder/Types.hs
@@ -1,25 +0,0 @@--- |Encoder Types-module Data.Flat.Encoder.Types(- Size,- NumBits,- Prim,- S(..)-) where--import Data.Flat.Types-import GHC.Ptr (Ptr (..))---- |Calculate the size (in bits) of the encoding of a value-type Size a = a -> NumBits -> NumBits---- |Strict encoder state-data S =- S- { nextPtr :: {-# UNPACK #-} !(Ptr Word8)- , currByte :: {-# UNPACK #-} !Word8- , usedBits :: {-# UNPACK #-} !NumBits- } deriving Show---- |A basic encoder-type Prim = S -> IO S-
− src/Data/Flat/Endian.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE CPP #-}--- | Endian utilities--- Exported for testing purposes, but not meant to be used outside this package.-module Data.Flat.Endian- (- toBE32- , toBE64- , toBE16- , isBigEndian- , fix64- ) where--#include "MachDeps.h"--import Data.Word--#ifdef ghcjs_HOST_OS-import Data.Bits-#endif--isBigEndian :: Bool-isBigEndian =-#ifdef WORDS_BIGENDIAN- True-#else- False-#endif---- | Convert a 64 bit value in cpu endianess to big endian-toBE64 :: Word64 -> Word64-#ifdef WORDS_BIGENDIAN-toBE64 = id-#else-toBE64 = byteSwap64-#endif---- | Convert a 32 bit value in cpu endianess to big endian-toBE32 :: Word32 -> Word32-#ifdef WORDS_BIGENDIAN-toBE32 = id-#else-toBE32 = byteSwap32-#endif---- | Convert a 16 bit value in cpu endianess to big endian-toBE16 :: Word16 -> Word16-#ifdef WORDS_BIGENDIAN-toBE16 = id-#else-toBE16 = byteSwap16-#endif---- | Fix issue with `ghcjs` (different order of 32 bit halves of 64 values with respect to `ghc`)-fix64 :: Word64 -> Word64-#ifdef ghcjs_HOST_OS-fix64 = (`rotateR` 32)-{-# NOINLINE fix64 #-}-#else-fix64 = id-{-# INLINE fix64 #-}-#endif
− src/Data/Flat/Filler.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}--- |Pre-value and post-value byte alignments-module Data.Flat.Filler (- Filler(..),- fillerLength,- PreAligned(..),- preAligned,- PostAligned(..),- postAligned,- postAlignedDecoder- ) where--import Data.Flat.Class-import Data.Flat.Encoder-import Data.Flat.Decoder-import Control.DeepSeq-import Data.Typeable---- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse)--- Useful to align an encoded value at byte/word boundaries.-data Filler = FillerBit Filler- | FillerEnd- deriving (Show, Eq, Ord, Typeable, Generic, NFData)---- |Use a special encoding for the filler-instance Flat Filler where- encode _ = eFiller- size = sFillerMax- -- use generated decode---- |A Post aligned value, a value followed by a filler-data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler }- deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)---- |A Pre aligned value, a value preceded by a filler-data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a }- deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat)---- |Length of a filler in bits-fillerLength :: Num a => Filler -> a-fillerLength FillerEnd = 1-fillerLength (FillerBit f) = 1 + fillerLength f---- |Post align a value-postAligned :: a -> PostAligned a-postAligned a = PostAligned a FillerEnd---- |Pre align a value-preAligned :: a -> PreAligned a-preAligned = PreAligned FillerEnd---- postAlignedDecoder :: Get a -> Get (PostAligned a)-postAlignedDecoder :: Get b -> Get b-postAlignedDecoder dec = do- v <- dec- _::Filler <- decode- -- return (postAligned v)- return v
− src/Data/Flat/Instances.hs
@@ -1,230 +0,0 @@--- {-# LANGUAGE BangPatterns #-}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--- {-# LANGUAGE UndecidableInstances #-}--- {-# LANGUAGE IncoherentInstances #-}---- |Flat Instances for common, primitive and abstract data types for which instances cannot be automatically derived-module Data.Flat.Instances- ( sizeMap- , encodeMap- , decodeMap- , sizeSequence- , encodeSequence- , decodeSequence- )-where--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Short as SBS-import Data.Char-import Data.Containers (ContainerKey, IsMap, MapValue,- mapFromList, mapToList)-import Data.Flat.Class-import Data.Flat.Decoder-import Data.Flat.Encoder---import Data.Flat.Size (arrayBits)-import Data.Flat.Types-import qualified Data.Foldable as F-import qualified Data.Map as M-import Data.MonoTraversable-import qualified Data.Sequence as S-import Data.Sequences-import qualified Data.Text as T-import Prelude hiding (mempty)---- Flat instances for common types-instance Flat () where- encode _ = mempty- decode = pure ()--instance Flat Bool where- encode = eBool- size = sBool- decode = dBool--instance Flat a => Flat (Maybe a)--instance (Flat a,Flat b) => Flat (Either a b)--instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a,b)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a,b,c)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d) => Flat (a,b,c,d)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e) => Flat (a,b,c,d,e)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) => Flat (a,b,c,d,e,f)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g) => Flat (a,b,c,d,e,f,g)---- Generic list instance.-instance {-# OVERLAPPABLE #-} Flat a => Flat [a]---- For better encoding/decoding performance, it is useful to declare instances of concrete list types.--- As this one for example:-instance {-# OVERLAPPING #-} Flat [Char]---- Flat instances for primitive/abstract types-instance Flat B.ByteString where- encode = eBytes- size = sBytes- decode = dByteString--instance Flat L.ByteString where- encode = eLazyBytes- size = sLazyBytes- decode = dLazyByteString--instance Flat SBS.ShortByteString where- encode = eShortBytes- size = sShortBytes- decode = dShortByteString--instance Flat T.Text where- size = sUTF8Max- encode = eUTF8- decode = dUTF8--instance Flat UTF8Text where- size (UTF8Text t)= sUTF8Max t- encode (UTF8Text t) = eUTF8 t- decode = UTF8Text <$> dUTF8--instance Flat UTF16Text where- size (UTF16Text t)= sUTF16 t- encode (UTF16Text t) = eUTF16 t- decode = UTF16Text <$> dUTF16--instance Flat Word8 where- encode = eWord8- decode = dWord8- size = sWord8--instance Flat Word16 where- encode = eWord16- decode = dWord16- size = sWord16--instance Flat Word32 where- encode = eWord32- decode = dWord32- size = sWord32--instance Flat Word64 where- encode = eWord64- decode = dWord64- size = sWord64--instance Flat Word where- size = sWord- encode = eWord- decode = dWord--instance Flat Int8 where- encode = eInt8- decode = dInt8- size = sInt8--instance Flat Int16 where- size = sInt16- encode = eInt16- decode = dInt16--instance Flat Int32 where- size = sInt32- encode = eInt32- decode = dInt32--instance Flat Int64 where- size = sInt64- encode = eInt64- decode = dInt64--instance Flat Int where- size = sInt- encode = eInt- decode = dInt--instance Flat Integer where- size = sInteger- encode = eInteger- decode = dInteger--instance Flat Natural where- size = sNatural- encode = eNatural- decode = dNatural--instance Flat Float where- size = sFloat- encode = eFloat- decode = dFloat--instance Flat Double where- size = sDouble- encode = eDouble- decode = dDouble--instance Flat Char where- size = sChar- encode = eChar- decode = dChar--instance (Flat a, Flat b,Ord a) => Flat (M.Map a b) where- size = sizeMap- encode = encodeMap- decode = decodeMap---- instance Flat a => Flat (IM.IntMap a) where--- size = sizeMap--- encode = encodeMap--- decode = decodeMap--instance Flat a => Flat (S.Seq a) where- size = sizeSequence- encode = encodeSequence- decode = decodeSequence---- |Calculate size of an instance of IsMap-{-# INLINE sizeMap #-}-sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r-sizeMap m acc =- F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1)- . mapToList- $ m--{-# INLINE encodeMap #-}--- |Encode an instance of IsMap, as a list-encodeMap- :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map)- => map- -> Encoding-encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList--- encodeMap = go . mapToList--- where--- go [] = eFalse--- go ((!x,!y):xs) = eTrue <> encode x <> encode y <> go xs--{-# INLINE decodeMap #-}--- |Decode an instance of IsMap, as a list-decodeMap- :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map-decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode)--{-# INLINE sizeSequence #-}--- |Calculate size of an instance of IsSequence-sizeSequence- :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits-sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s)--{-# INLINE encodeSequence #-}--- |Encode an instance of IsSequence, as an array-encodeSequence :: (Flat (Element mono), IsSequence mono) => mono -> Encoding-encodeSequence = encodeArrayWith encode . otoList--{-# INLINE decodeSequence #-}--- |Decode an instance of IsSequence, as an array-decodeSequence :: (Flat (Element b), IsSequence b) => Get b-decodeSequence = fromList <$> decodeArrayWith decode
− src/Data/Flat/Memory.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}--- |Memory access primitives-module Data.Flat.Memory- ( chunksToByteString- , chunksToByteArray- , ByteArray- , pokeByteArray- , pokeByteString- , unsafeCreateUptoN'- , minusPtr- )-where--import Control.Monad-import Control.Monad.Primitive ( PrimMonad(..) )-import qualified Data.ByteString.Internal as BS-import Data.Primitive.ByteArray ( MutableByteArray(..)- , ByteArray#- , ByteArray- , newByteArray- , unsafeFreezeByteArray- )-import Foreign hiding ( void )-import GHC.Prim ( copyAddrToByteArray#- , copyByteArrayToAddr#- )-import GHC.Ptr ( Ptr(..) )-import GHC.Types ( IO(..)- , Int(..)- )-import System.IO.Unsafe-import qualified Data.ByteString as B--unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a)-unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f)-{-# INLINE unsafeCreateUptoN' #-}--createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a)-createUptoN' l f = do- fp <- BS.mallocByteString l- (l', res) <- withForeignPtr fp $ \p -> f p- --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"])- when (l' > l) $ error- (unwords- ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"]- )- return (BS.PS fp 0 l', res) -- , minusPtr l')-{-# INLINE createUptoN' #-}---- |Copy bytestring to given pointer, returns new pointer-pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)-pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer =- do- withForeignPtr foreignPointer $ \sourcePointer -> BS.memcpy- destPointer- (sourcePointer `plusPtr` sourceOffset)- sourceLength- return (destPointer `plusPtr` sourceLength)--pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8)-pokeByteArray sourceArr sourceOffset len dest = do- copyByteArrayToAddr sourceArr sourceOffset dest len- let !dest' = dest `plusPtr` len- return dest'-{-# INLINE pokeByteArray #-}---- | Wrapper around @copyByteArrayToAddr#@ primop.--- Copied from the store-core package-copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()-copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) =- IO (\s -> (#copyByteArrayToAddr# arr offset addr len s, ()#))-{-# INLINE copyByteArrayToAddr #-}---- toByteString :: Ptr Word8 -> Int -> BS.ByteString--- toByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength--chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString-chunksToByteString (sourcePtr0, lens) =- BS.unsafeCreate (sum lens) $ \destPtr0 -> void $ foldM- (\(destPtr, sourcePtr) sourceLength ->- BS.memcpy destPtr sourcePtr sourceLength- >> return- ( destPtr `plusPtr` sourceLength- , sourcePtr `plusPtr` (sourceLength + 1)- )- )- (destPtr0, sourcePtr0)- lens--chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int)-chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do- let len = sum lens- arr <- newByteArray len- foldM_- (\(destOff, sourcePtr) sourceLength ->- copyAddrToByteArray sourcePtr arr destOff sourceLength >> return- (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1))- )- (0, sourcePtr0)- lens- farr <- unsafeFreezeByteArray arr- return (farr, len)---- from store-core--- | Wrapper around @copyAddrToByteArray#@ primop.-copyAddrToByteArray- :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO ()-copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) =- IO (\s -> (#copyAddrToByteArray# addr arr offset len s, ()#))-{-# INLINE copyAddrToByteArray #-}
− src/Data/Flat/Run.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--- |Encoding and decoding functions-module Data.Flat.Run (- flat,- flatRaw,- unflat,- unflatWith,- unflatRaw,- unflatRawWith,- ) where--import qualified Data.ByteString as B-import Data.ByteString.Convert-import Data.Flat.Class-import Data.Flat.Decoder-import qualified Data.Flat.Encoder as E-import Data.Flat.Filler---- |Encode padded value.-flat :: Flat a => a -> B.ByteString-flat = flatRaw . postAligned---- |Decode padded value.-unflat :: (Flat a,AsByteString b) => b -> Decoded a-unflat = unflatWith decode---- |Decode padded value, using the provided unpadded decoder.-unflatWith :: AsByteString b => Get a -> b -> Decoded a-unflatWith dec = unflatRawWith (postAlignedDecoder dec)---- |Decode unpadded value.-unflatRaw :: (Flat a,AsByteString b) => b -> Decoded a-unflatRaw = unflatRawWith decode---- |Unflat unpadded value, using provided decoder-unflatRawWith :: AsByteString b => Get a -> b -> Decoded a-unflatRawWith dec = strictDecoder dec . toByteString---- |Encode unpadded value-flatRaw :: (Flat a, AsByteString b) => a -> b-flatRaw a = fromByteString $ E.strictEncoder (getSize a) (encode a)-
− src/Data/Flat/Types.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |Common Types-module Data.Flat.Types (- NumBits,- module Data.Word,- module Data.Int,- Natural,- SBS.ShortByteString,- T.Text,- UTF8Text(..),- UTF16Text(..),- ) where--import qualified Data.ByteString.Short.Internal as SBS-import Data.Int-import qualified Data.Text as T-import Data.Word-import Numeric.Natural---- |Number of bits-type NumBits = Int---- |A wrapper to encode/decode Text as UTF8 (slower but more compact)-newtype UTF8Text = UTF8Text T.Text deriving (Eq,Ord,Show)---- |A wrapper to encode/decode Text as UTF16 (faster but bigger)-newtype UTF16Text = UTF16Text T.Text deriving (Eq,Ord,Show)
src/Data/FloatCast.hs view
@@ -1,72 +1,94 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}--- | Primitives to convert between Float/Double and Word32/Word64--- | This code was copied from `binary`--- | This module was written based on--- <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.------ Implements casting via a 1-element STUArray, as described in--- <http://stackoverflow.com/a/7002812/263061>.+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}++{- | Primitives to convert between Float\/Double and Word32\/Word64.++Code copied from <https://hackage.haskell.org/package/binary binary>.++Based on: <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>..++Implements casting via a 1-element STUArray, as described in <http://stackoverflow.com/a/7002812/263061>.+-} module Data.FloatCast ( floatToWord , wordToFloat , doubleToWord , wordToDouble+ , runST+ , cast ) where -import Data.Word ( Word32- , Word64- )-import Data.Array.ST ( newArray- , readArray- , MArray- , STUArray- )-import Data.Array.Unsafe ( castSTUArray )-import GHC.ST ( runST- , ST- )-import Data.Flat.Endian+import Data.Array.ST (MArray, STUArray, newArray, readArray)+import Data.Array.Unsafe (castSTUArray)+import Data.Word (Word32, Word64)+import GHC.ST (ST, runST)+-- import Flat.Endian ++++{- | Reinterpret-casts a `Word32` to a `Float`.++prop> \f -> wordToFloat (floatToWord f ) == f++++ OK, passed 100 tests.++>>> floatToWord (-0.15625)+3189768192++>>> wordToFloat 3189768192+-0.15625++>>> floatToWord (-5.828125) == 0xC0BA8000+True+-}+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}+ -- | Reinterpret-casts a `Float` to a `Word32`. floatToWord :: Float -> Word32 floatToWord x = runST (cast x) {-# INLINE floatToWord #-} --- | Reinterpret-casts a `Double` to a `Word64`.+-- $setup+-- >>> import Numeric (showHex)+-- >>> import Data.Word+ {-|->>> doubleToWord (-0.15625)-13818169556679524352--}-doubleToWord :: Double -> Word64-doubleToWord x = fix64 $ runST (cast x)+Reinterpret-casts a `Double` to a `Word64`. --- #ifdef ghcjs_HOST_OS--- doubleToWord x = (`rotateR` 32) $ runST (cast x)--- #else--- doubleToWord x = runST (cast x)--- #endif+prop> \f -> wordToDouble (doubleToWord f ) == f++++ OK, passed 100 tests. -{-# INLINE doubleToWord #-}+>>> showHex (doubleToWord 1.0000000000000004) ""+"3ff0000000000002" --- | Reinterpret-casts a `Word32` to a `Float`.-wordToFloat :: Word32 -> Float-wordToFloat x = runST (cast x)-{-# INLINE wordToFloat #-}+>>> doubleToWord 1.0000000000000004 == 0x3FF0000000000002+True +>>> showHex (doubleToWord (-0.15625)) ""+"bfc4000000000000"++>>> wordToDouble 0xbfc4000000000000+-0.15625+-}+{-# INLINE doubleToWord #-}+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+-- doubleToWord x = fix64 $ runST (cast x)+ -- | Reinterpret-casts a `Word64` to a `Double`. {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double-wordToDouble x = runST (cast $ fix64 x)---- #ifdef ghcjs_HOST_OS--- wordToDouble x = runST (cast $ x `rotateR` 32) --- #else--- wordToDouble x = runST (cast x) --- #endif+wordToDouble x = runST (cast x)+-- wordToDouble x = runST (cast $ fix64 x) +-- |+-- >>> runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64)+-- True cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
src/Data/ZigZag.hs view
@@ -1,66 +1,127 @@-module Data.ZigZag(zzEncode,zzEncodeInteger,zzDecode8,zzDecode16,zzDecode32,zzDecode64,zzDecodeInteger,zzDecode) where+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} -import Data.Word-import Data.Int-import Data.Bits+-- |<https://gist.github.com/mfuerstenau/ba870a29e16536fdbaba ZigZag encoding> of signed integrals.+module Data.ZigZag (ZigZag(..)) where -{-# SPECIALIZE INLINE zzEncode :: Int8 -> Word8 #-}-{-# SPECIALIZE INLINE zzEncode :: Int16 -> Word16 #-}-{-# SPECIALIZE INLINE zzEncode :: Int32 -> Word32 #-}-{-# SPECIALIZE INLINE zzEncode :: Int64 -> Word64 #-}-zzEncode :: (Num b, Integral a, FiniteBits a) => a -> b-zzEncode w = fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w -1)))+import Data.Bits (Bits (shiftL, shiftR, xor, (.&.)),+ FiniteBits (finiteBitSize))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)+import Numeric.Natural (Natural) ---{-# INLINE zzEncode8 #-}---zzEncode8 :: Int8 -> Word8--- zzEncode8 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 7))+-- $setup+-- >>> :set -XNegativeLiterals -XScopedTypeVariables -XFlexibleContexts+-- >>> import Data.Word+-- >>> import Data.Int+-- >>> import Numeric.Natural+-- >>> import Test.QuickCheck.Arbitrary+-- >>> instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral --- {-# INLINE zzEncode16 #-}--- zzEncode16 :: Int16 -> Word16--- zzEncode16 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 15))+{-|+Convert between a signed integral and the corresponding ZigZag encoded unsigned integral (e.g. between Int8 and Word8 or Integral and Natural). --- {-# INLINE zzEncode32 #-}--- zzEncode32 :: Int32 -> Word32--- zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 31))+Allow conversion only between compatible types, invalid conversions produce a type error: --- {-# INLINE zzEncode64 #-}--- zzEncode64 :: Int64 -> Word64--- zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))+@+zigZag (-1::Int64) :: Word32+...+... Couldn't match type ...+...+@+>>> zigZag (0::Int8)+0 -{-# INLINE zzEncodeInteger #-}-zzEncodeInteger :: Integer -> Integer-zzEncodeInteger x | x>=0 = x `shiftL` 1- | otherwise = negate (x `shiftL` 1) - 1+>>> zigZag (-1::Int16)+1 --- {-# SPECIALIZE INLINE zzDecode :: Word8 -> Int8 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word16 -> Int16 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word32 -> Int32 #-}--- {-# SPECIALIZE INLINE zzDecode :: Word64 -> Int64 #-}--- {-# SPECIALIZE INLINE zzDecode :: Integer -> Integer #-}+>>> zigZag (1::Int32)+2 -{-# INLINE zzDecode #-}-zzDecode :: (Num a, Integral a1, Bits a1) => a1 -> a-zzDecode w = fromIntegral ((w `shiftR` 1) `xor` (negate (w .&. 1)))--- zzDecode w = (fromIntegral (w `shiftR` 1)) `xor` (negate (fromIntegral (w .&. 1)))+>>> zigZag (-2::Int16)+3 -{-# INLINE zzDecode8 #-}-zzDecode8 :: Word8 -> Int8-zzDecode8 = zzDecode+>>> zigZag (-50::Integer)+99 -{-# INLINE zzDecode16 #-}-zzDecode16 :: Word16 -> Int16-zzDecode16 = zzDecode+>>> zigZag (50::Integer)+100 -{-# INLINE zzDecode32 #-}-zzDecode32 :: Word32 -> Int32-zzDecode32 = zzDecode+>>> zigZag (64::Integer)+128 -{-# INLINE zzDecode64 #-}-zzDecode64 :: Word64 -> Int64-zzDecode64 = zzDecode+>>> zigZag (-256::Integer)+511 -{-# INLINE zzDecodeInteger #-}-zzDecodeInteger :: Integer -> Integer-zzDecodeInteger = zzDecode+>>> zigZag (256::Integer)+512 +>>> map zigZag [-3..3::Integer]+[5,3,1,0,2,4,6] +>>> map zagZig [0..6::Word8]+[0,-1,1,-2,2,-3,3]++prop> \(f::Integer) -> zagZig (zigZag f) == f++++ OK, passed 100 tests.++prop> \(f::Natural) -> zigZag (zagZig f) == f++++ OK, passed 100 tests.++prop> \(f::Int8) -> zagZig (zigZag f) == f++++ OK, passed 100 tests.++prop> \(f::Word8) -> zigZag (zagZig f) == f++++ OK, passed 100 tests.++prop> \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer))++++ OK, passed 100 tests.++prop> \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural))++++ OK, passed 100 tests.++prop> \(f::Int64) -> zagZig (zigZag f) == f++++ OK, passed 100 tests.++prop> \(f::Word64) -> zigZag (zagZig f) == f++++ OK, passed 100 tests.++prop> \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer))++++ OK, passed 100 tests.++prop> \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural))++++ OK, passed 100 tests.+-}+class (Integral signed, Integral unsigned)+ => ZigZag signed unsigned | unsigned -> signed, signed -> unsigned where+ zigZag :: signed -> unsigned+ default zigZag :: FiniteBits signed => signed -> unsigned+ zigZag s = fromIntegral+ ((s `shiftL` 1) `xor` (s `shiftR` (finiteBitSize s - 1)))++ {-# INLINE zigZag #-}+ zagZig :: unsigned -> signed+ default zagZig :: (Bits unsigned) => unsigned -> signed+ zagZig u = fromIntegral ((u `shiftR` 1) `xor` negate (u .&. 1))++ -- default zagZig :: (Bits signed) => unsigned -> signed+ -- zagZig u = let (s::signed) = fromIntegral u in ((s `shiftR` 1) `xor` (negate (s .&. 1)))+ {-# INLINE zagZig #-}++instance ZigZag Int8 Word8++instance ZigZag Int16 Word16++instance ZigZag Int32 Word32++instance ZigZag Int64 Word64++instance ZigZag Integer Natural where+ zigZag x+ | x >= 0 = fromIntegral $ x `shiftL` 1+ | otherwise = fromIntegral $ negate (x `shiftL` 1) - 1++ zagZig u = let s = fromIntegral u+ in ((s `shiftR` 1) `xor` negate (s .&. 1))
+ src/Flat.hs view
@@ -0,0 +1,21 @@+{-|+Haskell implementation of <http://quid2.org/docs/Flat.pdf Flat>, a principled, portable and efficient binary data format.++-}+module Flat+ ( module Flat.Class+ , module Flat.Filler+ , module X+ , Decoded+ , DecodeException(..)+ )+where++import Flat.AsBin as X+import Flat.AsSize as X+import Flat.Class+import Flat.Decoder+import Flat.Filler+import Flat.Instances as X+import Flat.Run as X+import Flat.Types ()
+ src/Flat/AsBin.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Wrapper type to decode a value to its flat serialisation.++See <../test/Big.hs> for an example of use.++See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values.++In 0.5.X this type was called @Repr@.++@since 0.6+-}+module Flat.AsBin(AsBin,unbin) where++import qualified Data.ByteString as B+import Flat.Bits (bits, fromBools, toBools)+import Flat.Class (Flat (..))+import Flat.Decoder.Prim (binOf)+import Flat.Decoder.Types (Get (Get, runGet),+ GetResult (GetResult),+ S (S, currPtr, usedBits))+import Flat.Run (unflatRawWithOffset)+import Foreign (plusPtr)+import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint),+ prettyShow, text)++-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> import Flat.Instances.Base+-- >>> import Flat.Instances.Text+-- >>> import Flat.Decoder.Types+-- >>> import Flat.Types+-- >>> import Flat.Run+-- >>> import Data.Word+-- >>> import qualified Data.Text as T+-- >>> import Text.PrettyPrint.HughesPJClass++{- |++When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand.++To do so, just decode a value `a` as a `AsBin a`.++Examples:++Encode a list of Ints and then decode it to a list of AsBin Int:++>>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int])+Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}]++To decode an `AsBin a` to an `a`, use `unbin`:++>>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char))+Right 'a'++Keep the values of a list of Ints encoded and decode just one on demand:++>>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2)+3++Show exactly how values are encoded:++>>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t+"(0, _0000001 1, _1)"++Ten bits in total spread over two bytes:++@+0+_0000001 1+ _1+=+00000001 11+@++Tests:++>>> unflat (flat ()) :: Decoded (AsBin ())+Right (AsBin {repr = "", offsetBits = 0})++>>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool)+Right (False,AsBin {repr = "A", offsetBits = 1})++>>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8)+Right (False,False,AsBin {repr = "?\193", offsetBits = 2})++>>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3)+(False,False,255,True)+-}++data AsBin a = AsBin {+ repr :: B.ByteString -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte)+ ,offsetBits :: Int -- ^ First byte offset: number of unused most significant bits in the first byte+ } deriving Show++instance Flat a => Pretty (AsBin a) where+ pPrint :: AsBin a -> Doc+ pPrint r = let n = replicate (offsetBits r) in text $ n '_' ++ (drop (offsetBits r) . prettyShow . fromBools . (n False ++) . toBools . bits $ unbin r)++-- | Decode a value+unbin :: Flat a => AsBin a -> a+unbin a =+ case unflatRawWithOffset dec (repr a) (offsetBits a) of+ Right a -> a+ Left e -> error (show e) -- impossible, as it is a valid encoding+ where+ dec = Get $ \end s -> do+ GetResult s' a <- runGet decode end s+ let s'' = S (currPtr s' `plusPtr` if usedBits s' == 0 then 0 else 1) 0+ return $ GetResult s'' a++instance Flat a => Flat (AsBin a) where+ size = error "unused"++ encode = error "unused"++ decode :: Flat a => Get (AsBin a)+ decode = uncurry AsBin <$> binOf (decode :: Get a)
+ src/Flat/AsSize.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Wrapper type to decode a value to its size in bits.++See also "Flat.AsBin".++In 0.5.X this type was called @SizeOf@.++@since 0.6+-}+module Flat.AsSize(AsSize(..)) where++import Flat.Class (Flat (..))+import Flat.Decoder.Prim (sizeOf)+import Flat.Decoder.Types (Get)+import Flat.Types (NumBits)++-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> import Flat.Instances.Base+-- >>> import Flat.Instances.Text+-- >>> import Flat.Decoder.Types+-- >>> import Flat.Types+-- >>> import Flat.Run+-- >>> import Data.Word+-- >>> import qualified Data.Text as T++{- |+Useful to skip unnecessary values and to check encoding sizes.++Examples:++Ignore the second and fourth component of a tuple:++>>> let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool)+Right ('a',AsSize 28,'z',AsSize 1)++Notice the variable size encoding of Words:++>>> unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64)+Right (AsSize 8,AsSize 8)++Text:++>>> unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text)+Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40)++Various encodings:++>>> unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char)+Right (AsSize 1,AsSize 96,AsSize 8)+-}+newtype AsSize a = AsSize NumBits deriving (Eq,Ord,Show)++instance Flat a => Flat (AsSize a) where+ size :: Flat a => AsSize a -> NumBits -> NumBits+ size = error "unused"++ encode = error "unused"++ decode :: Flat a => Get (AsSize a)+ decode = AsSize <$> sizeOf (decode :: Get a)
+ src/Flat/Bits.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+++-- |Utilities to represent and display bit sequences+module Flat.Bits (+ Bits,+ toBools,+ fromBools,+ bits,+ paddedBits,+ asBytes,+ asBits,+ takeBits,+ takeAllBits,+) where+-- TODO: AsBits Class?++import Data.Bits (FiniteBits (finiteBitSize),+ testBit)+import qualified Data.ByteString as B+import qualified Data.Vector.Unboxed as V+import Data.Word (Word8)+import Flat.Class (Flat)+import Flat.Decoder (Decoded)+import Flat.Filler (PostAligned (PostAligned),+ fillerLength)+import Flat.Run (flat, unflatRaw)+import Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint), hsep,+ text)++-- |A sequence of bits+type Bits = V.Vector Bool++toBools :: Bits -> [Bool]+toBools = V.toList++fromBools :: [Bool] -> Bits+fromBools = V.fromList++{- $setup+>>> import Data.Word+>>> import Flat.Instances.Base+>>> import Flat.Instances.Test(tst,prettyShow)+-}++{- |The sequence of bits corresponding to the serialization of the passed value (without any final byte padding)++>>> bits True+[True]+-}+bits :: forall a. Flat a => a -> Bits+bits v =+ let lbs = flat v+ in case unflatRaw lbs :: Decoded (PostAligned a) of + Right (PostAligned _ f) -> takeBits (8 * B.length lbs - fillerLength f) lbs+ Left _ -> error "incorrect coding or decoding, please inform the maintainer of this package"++{- |The sequence of bits corresponding to the byte-padded serialization of the passed value++>>> paddedBits True+[True,False,False,False,False,False,False,True]+-}+paddedBits :: forall a. Flat a => a -> Bits+paddedBits v = let lbs = flat v in takeAllBits lbs++takeAllBits :: B.ByteString -> Bits+takeAllBits lbs= takeBits (8 * B.length lbs) lbs++takeBits :: Int -> B.ByteString -> Bits+takeBits numBits lbs =+ V.generate+ (fromIntegral numBits)+ ( \n ->+ let (bb, b) = n `divMod` 8+ in testBit (B.index lbs (fromIntegral bb)) (7 - b)+ )++{- |Convert an integral value to its equivalent bit representation++>>> asBits (5::Word8)+[False,False,False,False,False,True,False,True]+-}+asBits :: FiniteBits a => a -> Bits+asBits w = let s = finiteBitSize w in V.generate s (testBit w . (s - 1 -))++{- |Convert a sequence of bits to the corresponding list of bytes++>>> asBytes $ asBits (256+3::Word16)+[1,3]+-}+asBytes :: Bits -> [Word8]+asBytes = map byteVal . bytes . V.toList++-- |Convert to the corresponding value (most significant bit first)+byteVal :: [Bool] -> Word8+byteVal = sum . zipWith (\ e b -> (if b then e else 0)) ([2 ^ n | n <- [7 :: Int, 6 .. 0]])++-- |Split a list in groups of 8 elements or less+bytes :: [t] -> [[t]]+bytes [] = []+bytes l = let (w, r) = splitAt 8 l in w : bytes r++{- |+>>> prettyShow $ asBits (256+3::Word16)+"00000001 00000011"+-}+instance Pretty Bits where+ pPrint = hsep . map prettyBits . bytes . V.toList++prettyBits :: Foldable t => t Bool -> Doc+prettyBits l =+ text . take (length l) . concatMap (\b -> if b then "1" else "0") $ l
+ src/Flat/Class.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |Generics-based generation of Flat instances+module Flat.Class+ (+ -- * The Flat class+ Flat(..)+ , getSize+ , module GHC.Generics+ , GFlatEncode,GFlatDecode,GFlatSize+ )+where++import Data.Bits (Bits (unsafeShiftL, (.|.)))+import Data.Word (Word16)+import Flat.Decoder.Prim (ConsState (..), consBits, consBool,+ consClose, consOpen, dBool)+import Flat.Decoder.Types (Get)+import Flat.Encoder (Encoding, NumBits, eBits16, mempty)+import GHC.Generics+import GHC.TypeLits (Nat, type (+), type (<=))+import Prelude hiding (mempty)++#if MIN_VERSION_base(4,9,0)+import Data.Kind+#endif++#if ! MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif+++-- External and Internal inlining+#define INL 2+-- Internal inlining+-- #define INL 1+-- No inlining+-- #define INL 0++#if INL == 1+import GHC.Exts (inline)+#endif++-- import Data.Proxy++-- |Calculate the maximum size in bits of the serialisation of the value+getSize :: Flat a => a -> NumBits+getSize a = size a 0++{-| Class of types that can be encoded/decoded++Encoding a value involves three steps:++* calculate the maximum size of the serialised value, using `size`++* preallocate a buffer of the required size++* encode the value in the buffer, using `encode`+-}+class Flat a where+ -- |Return the encoding corrresponding to the value+ encode :: a -> Encoding+ default encode :: (Generic a, GFlatEncode (Rep a)) => a -> Encoding+ encode = gencode . from++ -- |Decode a value+ decode :: Get a+ default decode :: (Generic a, GFlatDecode (Rep a)) => Get a+ decode = to `fmap` gget++ -- |Add maximum size in bits of the value to the total count+ --+ -- Used to calculated maximum buffer size before encoding+ size :: a -> NumBits -> NumBits+ default size :: (Generic a, GFlatSize (Rep a)) => a -> NumBits -> NumBits+ size !x !n = gsize n $ from x++#if INL>=2+ -- With these, generated code is optimised for specific data types (e.g.: Tree Bool will fuse the code of Tree and Bool)+ -- This can improve performance very significantly (up to 10X) but also increases compilation times.+ {-# INLINE size #-}+ {-# INLINE decode #-}+ {-# INLINE encode #-}+#elif INL == 1+#elif INL == 0+ {-# NOINLINE size #-}+ {-# NOINLINE decode #-}+ {-# NOINLINE encode #-}+#endif++-- |Generic Encoder+class GFlatEncode f where gencode :: f a -> Encoding++instance {-# OVERLAPPABLE #-} GFlatEncode f => GFlatEncode (M1 i c f) where+ gencode = gencode . unM1+ {-# INLINE gencode #-}++ -- Special case, single constructor datatype+instance {-# OVERLAPPING #-} GFlatEncode a => GFlatEncode (D1 i (C1 c a)) where+ gencode = gencode . unM1 . unM1+ {-# INLINE gencode #-}++ -- Type without constructors+instance GFlatEncode V1 where+ gencode = unused+ {-# INLINE gencode #-}++ -- Constructor without arguments+instance GFlatEncode U1 where+ gencode U1 = mempty+ {-# INLINE gencode #-}++instance Flat a => GFlatEncode (K1 i a) where+ {-# INLINE gencode #-}+#if INL == 1+ gencode x = inline encode (unK1 x)+#else+ gencode = encode . unK1+#endif++instance (GFlatEncode a, GFlatEncode b) => GFlatEncode (a :*: b) where+ --gencode (!x :*: (!y)) = gencode x <++> gencode y+ gencode (x :*: y) = gencode x <> gencode y+ {-# INLINE gencode #-}++instance (NumConstructors (a :+: b) <= 512,GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where+-- instance (GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where+ gencode = gencodeSum 0 0+ {-# INLINE gencode #-}++-- Constructor Encoding+class GFlatEncodeSum f where+ gencodeSum :: Word16 -> NumBits -> f a -> Encoding++instance (GFlatEncodeSum a, GFlatEncodeSum b) => GFlatEncodeSum (a :+: b) where+ gencodeSum !code !numBits s = case s of+ L1 !x -> gencodeSum (code `unsafeShiftL` 1) (numBits+1) x+ R1 !x -> gencodeSum ((code `unsafeShiftL` 1) .|. 1) (numBits+1) x+ {-# INLINE gencodeSum #-}++instance GFlatEncode a => GFlatEncodeSum (C1 c a) where+ gencodeSum !code !numBits x = eBits16 numBits code <> gencode x+ {-# INLINE gencodeSum #-}++-- |Generic Decoding+class GFlatDecode f where+ gget :: Get (f t)++-- |Metadata (constructor name, etc)+instance GFlatDecode a => GFlatDecode (M1 i c a) where+ gget = M1 <$> gget+ {-# INLINE gget #-}++-- |Type without constructors+instance GFlatDecode V1 where+ gget = unused+ {-# INLINE gget #-}++-- |Constructor without arguments+instance GFlatDecode U1 where+ gget = pure U1+ {-# INLINE gget #-}++-- |Product: constructor with parameters+instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :*: b) where+ gget = (:*:) <$> gget <*> gget+ {-# INLINE gget #-}++-- |Constants, additional parameters, and rank-1 recursion+instance Flat a => GFlatDecode (K1 i a) where+#if INL == 1+ gget = K1 <$> inline decode+#else+ gget = K1 <$> decode+#endif+ {-# INLINE gget #-}+++-- Different valid decoding setups+-- #define DEC_BOOLG+-- #define DEC_BOOL++-- #define DEC_BOOLG+-- #define DEC_BOOL+-- #define DEC_BOOL48++-- #define DEC_CONS+-- #define DEC_BOOLC+-- #define DEC_BOOL++-- #define DEC_CONS+-- #define DEC_BOOLC+-- #define DEC_BOOL+-- #define DEC_BOOL48++-- #define DEC_CONS++-- #define DEC_CONS+-- #define DEC_CONS48++#define DEC_CONS+#define DEC_CONS48+#define DEC_BOOLC+#define DEC_BOOL++#ifdef DEC_BOOLG+instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b)+#endif++#ifdef DEC_BOOLC+-- Special case for data types with two constructors+instance {-# OVERLAPPING #-} (GFlatDecode a,GFlatDecode b) => GFlatDecode (C1 m1 a :+: C1 m2 b)+#endif++#ifdef DEC_BOOL+ where+ gget = do+ -- error "DECODE2_C2"+ !tag <- dBool+ !r <- if tag then R1 <$> gget else L1 <$> gget+ return r+ {-# INLINE gget #-}+#endif++#ifdef DEC_CONS+-- | Data types with up to 512 constructors+-- Uses a custom constructor decoding state+-- instance {-# OVERLAPPABLE #-} (GFlatDecodeSum (a :+: b),GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) where+instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GFlatDecodeSum (a :+: b)) => GFlatDecode (a :+: b) where+ gget = do+ cs <- consOpen+ getSum cs+ {-# INLINE gget #-}++-- |Constructor Decoder+class GFlatDecodeSum f where+ getSum :: ConsState -> Get (f a)++#ifdef DEC_CONS48++-- Decode constructors in groups of 2 or 3 bits+-- Significantly reduce instance compilation time and slightly improve execution times+instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4) => GFlatDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined+ where+ getSum cs = do+ -- error "DECODE4"+ let (cs',tag) = consBits cs 2+ case tag of+ 0 -> L1 . L1 <$> getSum cs'+ 1 -> L1 . R1 <$> getSum cs'+ 2 -> R1 . L1 <$> getSum cs'+ _ -> R1 . R1 <$> getSum cs'+ {-# INLINE getSum #-}++instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4,GFlatDecodeSum n5,GFlatDecodeSum n6,GFlatDecodeSum n7,GFlatDecodeSum n8) => GFlatDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined+ where+ getSum cs = do+ --error "DECODE8"+ let (cs',tag) = consBits cs 3+ case tag of+ 0 -> L1 . L1 . L1 <$> getSum cs'+ 1 -> L1 . L1 . R1 <$> getSum cs'+ 2 -> L1 . R1 . L1 <$> getSum cs'+ 3 -> L1 . R1 . R1 <$> getSum cs'+ 4 -> R1 . L1 . L1 <$> getSum cs'+ 5 -> R1 . L1 . R1 <$> getSum cs'+ 6 -> R1 . R1 . L1 <$> getSum cs'+ _ -> R1 . R1 . R1 <$> getSum cs'+ {-# INLINE getSum #-}++instance {-# OVERLAPPABLE #-} (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where+#else+instance (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where+#endif++ getSum cs = do+ let (cs',tag) = consBool cs+ if tag then R1 <$> getSum cs' else L1 <$> getSum cs'+ {-# INLINE getSum #-}+++instance GFlatDecode a => GFlatDecodeSum (C1 c a) where+ getSum (ConsState _ usedBits) = consClose usedBits >> gget+ {-# INLINE getSum #-}+#endif++#ifdef DEC_BOOL48+instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4) => GFlatDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined+ where+ gget = do+ -- error "DECODE4"+ !tag <- dBEBits8 2+ case tag of+ 0 -> L1 <$> L1 <$> gget+ 1 -> L1 <$> R1 <$> gget+ 2 -> R1 <$> L1 <$> gget+ _ -> R1 <$> R1 <$> gget+ {-# INLINE gget #-}++instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4,GFlatDecode n5,GFlatDecode n6,GFlatDecode n7,GFlatDecode n8) => GFlatDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined+ where+ gget = do+ --error "DECODE8"+ !tag <- dBEBits8 3+ case tag of+ 0 -> L1 <$> L1 <$> L1 <$> gget+ 1 -> L1 <$> L1 <$> R1 <$> gget+ 2 -> L1 <$> R1 <$> L1 <$> gget+ 3 -> L1 <$> R1 <$> R1 <$> gget+ 4 -> R1 <$> L1 <$> L1 <$> gget+ 5 -> R1 <$> L1 <$> R1 <$> gget+ 6 -> R1 <$> R1 <$> L1 <$> gget+ _ -> R1 <$> R1 <$> R1 <$> gget+ {-# INLINE gget #-}+#endif++-- |Calculate the number of bits required for the serialisation of a value+-- Implemented as a function that adds the maximum size to a running total+class GFlatSize f where gsize :: NumBits -> f a -> NumBits++-- |Skip metadata+instance GFlatSize f => GFlatSize (M1 i c f) where+ gsize !n = gsize n . unM1+ {-# INLINE gsize #-}++-- |Type without constructors+instance GFlatSize V1 where+ gsize !n _ = n+ {-# INLINE gsize #-}++-- |Constructor without arguments+instance GFlatSize U1 where+ gsize !n _ = n+ {-# INLINE gsize #-}++-- |Skip metadata+instance Flat a => GFlatSize (K1 i a) where+#if INL == 1+ gsize !n x = inline size (unK1 x) n+#else+ gsize !n x = size (unK1 x) n+#endif+ {-# INLINE gsize #-}++instance (GFlatSize a, GFlatSize b) => GFlatSize (a :*: b) where+ gsize !n (x :*: y) =+ let !n' = gsize n x+ in gsize n' y+ -- gsize (gsize n x) y+ {-# INLINE gsize #-}++-- Alternative 'gsize' implementations+#define SIZ_ADD+-- #define SIZ_NUM++-- #define SIZ_MAX+-- #define SIZ_MAX_VAL+-- #define SIZ_MAX_PROX++#ifdef SIZ_ADD+instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where+ gsize !n = gsizeSum n+#endif++#ifdef SIZ_NUM+instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where+ gsize !n x = n + gsizeSum 0 x+#endif++#ifdef SIZ_MAX+instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where+ gsize !n x = gsizeNxt (gsizeMax x + n) x+ {-# INLINE gsize #-}++-- |Calculate the maximum size of a class constructor (that might be one bit more than the size of some of its constructors)+#ifdef SIZ_MAX_VAL+class GFlatSizeMax (f :: * -> *) where gsizeMax :: f a -> NumBits++instance (GFlatSizeMax f, GFlatSizeMax g) => GFlatSizeMax (f :+: g) where+ gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a))+ {-# INLINE gsizeMax #-}++instance (GFlatSize a) => GFlatSizeMax (C1 c a) where+ {-# INLINE gsizeMax #-}+ gsizeMax _ = 0+#endif++#ifdef SIZ_MAX_PROX+-- instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where+-- gsize !n x = gsizeNxt (gsizeMax x + n) x+-- {-# INLINE gsize #-}+++-- -- |Calculate size in bits of constructor+-- class KnownNat n => GFlatSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits++-- instance (GFlatSizeMax (n + 1) a, GFlatSizeMax (n + 1) b, KnownNat n) => GFlatSizeMax n (a :+: b) where+-- gsizeMax !n x _ = case x of+-- L1 !l -> gsizeMax n l (Proxy :: Proxy (n+1))+-- R1 !r -> gsizeMax n r (Proxy :: Proxy (n+1))+-- {-# INLINE gsizeMax #-}++-- instance (GFlatSize a, KnownNat n) => GFlatSizeMax n (C1 c a) where+-- {-# INLINE gsizeMax #-}+-- gsizeMax !n !x _ = gsize (constructorSize + n) x+-- where+-- constructorSize :: NumBits+-- constructorSize = fromInteger (natVal (Proxy :: Proxy n))++-- class KnownNat (ConsSize f) => GFlatSizeMax (f :: * -> *) where+-- gsizeMax :: f a -> NumBits+-- gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f)))++type family ConsSize (a :: * -> *) :: Nat where+ ConsSize (C1 c a) = 0+ ConsSize (x :+: y) = 1 + Max (ConsSize x) (ConsSize y)++type family Max (n :: Nat) (m :: Nat) :: Nat where+ Max n m = If (n <=? m) m n++type family If c (t::Nat) (e::Nat) where+ If 'True t e = t+ If 'False t e = e+#endif++-- |Calculate the size of a value, not taking in account its constructor+class GFlatSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a -> NumBits++instance (GFlatSizeNxt a, GFlatSizeNxt b) => GFlatSizeNxt (a :+: b) where+ gsizeNxt n x = case x of+ L1 !l-> gsizeNxt n l+ R1 !r-> gsizeNxt n r+ {-# INLINE gsizeNxt #-}++instance (GFlatSize a) => GFlatSizeNxt (C1 c a) where+ {-# INLINE gsizeNxt #-}+ gsizeNxt !n !x = gsize n x+#endif++-- |Calculate size in bits of constructor+-- vs proxy implementation: similar compilation time but much better run times (at least for Tree N, -70%)+#if MIN_VERSION_base(4,9,0)+class GFlatSizeSum (f :: Type -> Type) where+#else+class GFlatSizeSum (f :: * -> *) where+#endif+ gsizeSum :: NumBits -> f a -> NumBits++instance (GFlatSizeSum a, GFlatSizeSum b)+ => GFlatSizeSum (a :+: b) where+ gsizeSum !n x = case x of+ L1 !l-> gsizeSum (n+1) l+ R1 !r-> gsizeSum (n+1) r+ {-# INLINE gsizeSum #-}++instance (GFlatSize a) => GFlatSizeSum (C1 c a) where+ {-# INLINE gsizeSum #-}+ gsizeSum !n !x = gsize n x+++-- |Calculate number of constructors+#if MIN_VERSION_base(4,9,0)+type family NumConstructors (a :: Type -> Type) :: Nat where+#else+type family NumConstructors (a :: * -> *) :: Nat where+#endif+ NumConstructors (C1 c a) = 1+ NumConstructors (x :+: y) = NumConstructors x + NumConstructors y++unused :: forall a . a+unused = error "Now, now, you could not possibly have meant this.."
+ src/Flat/Decoder.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+-- |Strict Decoder+module Flat.Decoder (+ strictDecoder,+ listTDecoder,+ Decoded,+ DecodeException(..),+ Get,+ dByteString,+ dLazyByteString,+ dShortByteString,+ dShortByteString_,+#if! defined (ETA_VERSION)+ dUTF16,+#endif+ dUTF8,+ decodeArrayWith,+ decodeListWith,+ dFloat,+ dDouble,+ dInteger,+ dNatural,+ dChar,+ dBool,+ dWord8,+ dWord16,+ dWord32,+ dWord64,+ dWord,+ dInt8,+ dInt16,+ dInt32,+ dInt64,+ dInt,+ dBE8,+ dBE16,+ dBE32,+ dBE64,+ dBEBits8,+ dBEBits16,+ dBEBits32,+ dBEBits64,+ dropBits,++ ConsState(..),consOpen,consClose,consBool,consBits+ ) where++import Flat.Decoder.Prim+import Flat.Decoder.Run+import Flat.Decoder.Strict+import Flat.Decoder.Types
+ src/Flat/Decoder/Prim.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |Strict Decoder Primitives+module Flat.Decoder.Prim (+ dBool,+ dWord8,+ dBE8,+ dBE16,+ dBE32,+ dBE64,+ dBEBits8,+ dBEBits16,+ dBEBits32,+ dBEBits64,+ dropBits,+ dFloat,+ dDouble,+ getChunksInfo,+ dByteString_,+ dLazyByteString_,+ dByteArray_,++ ConsState(..),consOpen,consClose,consBool,consBits,++ sizeOf,binOf+ ) where++import Control.Monad (when)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.FloatCast (wordToDouble, wordToFloat)+import Data.Word (Word16, Word32, Word64, Word8)+import Flat.Decoder.Types (Get (Get, runGet), GetResult (..),+ S (..), badEncoding, badOp,+ notEnoughSpace)+import Flat.Endian (toBE16, toBE32, toBE64)+import Flat.Memory (ByteArray, chunksToByteArray,+ chunksToByteString, minusPtr,+ peekByteString)+import Foreign (Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)),+ FiniteBits (finiteBitSize), Ptr,+ Storable (peek), castPtr, plusPtr,+ ptrToIntPtr)++-- $setup+-- >>> :set -XBinaryLiterals+-- >>> import Data.Word+-- >>> import Data.Int+-- >>> import Flat.Run+-- >>> import Flat.Bits+-- >>> import Text.PrettyPrint.HughesPJClass (Pretty (pPrint))++{- |A special state, optimised for constructor decoding.++It consists of:++* The bits to parse, the top bit being the first to parse (could use a Word16 instead, no difference in performance)++* The number of decoded bits++Supports up to 512 constructors (9 bits).+-}+data ConsState =+ ConsState {-# UNPACK #-} !Word !Int++-- |Switch to constructor decoding+-- {-# INLINE consOpen #-}+consOpen :: Get ConsState+consOpen = Get $ \endPtr s -> do+ let u = usedBits s+ let d = ptrToIntPtr endPtr - ptrToIntPtr (currPtr s)+ w <- if d > 1 then do -- two different bytes+ w16::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+ return $ fromIntegral w16 `unsafeShiftL` (u+(wordSize-16))+ else if d == 1 then do -- single last byte left+ w8 :: Word8 <- peek (currPtr s)+ return $ fromIntegral w8 `unsafeShiftL` (u+(wordSize-8))+ else notEnoughSpace endPtr s+ return $ GetResult s (ConsState w 0)++-- |Switch back to normal decoding+-- {-# NOINLINE consClose #-}+consClose :: Int -> Get ()+consClose n = Get $ \endPtr s -> do+ let u' = n+usedBits s+ if u' < 8+ then return $ GetResult (s {usedBits=u'}) ()+ else if currPtr s >= endPtr+ then notEnoughSpace endPtr s+ else return $ GetResult (s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}) ()++ {- ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s+ dropBits8 s n =+ let u' = n+usedBits s+ in if u' < 8+ then s {usedBits=u'}+ else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}+ -}++ --ensureBits endPtr s n+ --return $ GetResult (dropBits8 s n) ()++-- |Decode a single bit+consBool :: ConsState -> (ConsState,Bool)+consBool cs = (0/=) <$> consBits cs 1++-- consBool (ConsState w usedBits) = (ConsState (w `unsafeShiftL` 1) (1+usedBits),0 /= 32768 .&. w)++-- |Decode from 1 to 3 bits+--+-- It could read more bits that are available, but it doesn't matter, errors will be checked in consClose.+consBits :: ConsState -> Int -> (ConsState, Word)+consBits cs 3 = consBits_ cs 3 7+consBits cs 2 = consBits_ cs 2 3+consBits cs 1 = consBits_ cs 1 1+consBits _ _ = error "unsupported"++consBits_ :: ConsState -> Int -> Word -> (ConsState, Word)++-- Different decoding primitives+-- All with equivalent performance+-- #define CONS_ROT+-- #define CONS_SHL+#define CONS_STA++#ifdef CONS_ROT+consBits_ (ConsState w usedBits) numBits mask =+ let usedBits' = numBits+usedBits+ w' = w `rotateL` numBits -- compiles to an or+shiftl+shiftr+ in (ConsState w' usedBits',w' .&. mask)+#endif++#ifdef CONS_SHL+consBits_ (ConsState w usedBits) numBits mask =+ let usedBits' = numBits+usedBits+ w' = w `unsafeShiftL` numBits+ in (ConsState w' usedBits', (w `unsafeShiftR` (wordSize - numBits)) .&. mask)+#endif++#ifdef CONS_STA+consBits_ (ConsState w usedBits) numBits mask =+ let usedBits' = numBits+usedBits+ in (ConsState w usedBits', (w `unsafeShiftR` (wordSize - usedBits')) .&. mask)+#endif++wordSize :: Int+wordSize = finiteBitSize (0 :: Word)++{-# INLINE ensureBits #-}+-- |Ensure that the specified number of bits is available+ensureBits :: Ptr Word8 -> S -> Int -> IO ()+ensureBits endPtr s n = when ((endPtr `minusPtr` currPtr s) * 8 - usedBits s < n) $ notEnoughSpace endPtr s++{-# INLINE dropBits #-}+-- |Drop the specified number of bits+dropBits :: Int -> Get ()+dropBits n+ | n > 0 = Get $ \endPtr s -> do+ ensureBits endPtr s n+ return $ GetResult (dropBits_ s n) ()+ | n == 0 = return ()+ | otherwise = error $ unwords ["dropBits",show n]++{-# INLINE dropBits_ #-}+dropBits_ :: S -> Int -> S+dropBits_ s n =+ let (bytes,bits) = (n+usedBits s) `divMod` 8+ -- let+ -- n' = n+usedBits s+ -- bytes = n' `unsafeShiftR` 3+ -- bits = n' .|. 7+ in S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}++{-# INLINE dBool #-}+-- Inlining dBool massively increases compilation time but decreases run time by a third+-- TODO: test dBool inlining for ghc >= 8.8.4+-- |Decode a boolean+dBool :: Get Bool+dBool = Get $ \endPtr s ->+ if currPtr s >= endPtr+ then notEnoughSpace endPtr s+ else do+ !w <- peek (currPtr s)+ let !b = 0 /= (w .&. (128 `unsafeShiftR` usedBits s))+ let !s' = if usedBits s == 7+ then s { currPtr = currPtr s `plusPtr` 1, usedBits = 0 }+ else s { usedBits = usedBits s + 1 }+ return $ GetResult s' b+++{-# INLINE dBEBits8 #-}+{- | Return the n most significant bits (up to maximum of 8)++The bits are returned right shifted:++>>> unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111+True++>>> unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111]+Left (BadOp "read8: cannot read 9 bits")+-}+dBEBits8 :: Int -> Get Word8+dBEBits8 n = Get $ \endPtr s -> do+ ensureBits endPtr s n+ take8 s n++{-# INLINE dBEBits16 #-}+{- | Return the n most significant bits (up to maximum of 16)++The bits are returned right shifted:++>>> pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001]+Right 00000101 10111111++If more than 16 bits are requested, only the last 16 are returned:++>>> pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001]+Right 00000111 11111111+-}+dBEBits16 :: Int -> Get Word16+dBEBits16 n = Get $ \endPtr s -> do+ ensureBits endPtr s n+ takeN n s++{-# INLINE dBEBits32 #-}+-- |Return the n most significant bits (up to maximum of 32)+-- The bits are returned right shifted.+dBEBits32 :: Int -> Get Word32+dBEBits32 n = Get $ \endPtr s -> do+ ensureBits endPtr s n+ takeN n s++{-# INLINE dBEBits64 #-}+-- |Return the n most significant bits (up to maximum of 64)+-- The bits are returned right shifted.+dBEBits64 :: Int -> Get Word64+dBEBits64 n = Get $ \endPtr s -> do+ ensureBits endPtr s n+ takeN n s++-- {-# INLINE take8 #-}+-- take8 :: Int -> S -> IO (GetResult Word8)+-- take8 n s+-- | n == 0 = return $ GetResult s 0++-- -- all bits in the same byte+-- | n <= 8 - usedBits s = do+-- w <- peek (currPtr s)+-- let (bytes,bits) = (n+usedBits s) `divMod` 8+-- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n))++-- -- two different bytes+-- | n <= 8 = do+-- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+-- return $ GetResult (S {currPtr=currPtr s `plusPtr` 1,usedBits=(usedBits s + n) `mod` 8}) (fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n))++-- | otherwise = error $ unwords ["take8: cannot take",show n,"bits"]++{-# INLINE take8 #-}+take8 :: S -> Int -> IO (GetResult Word8)+-- take8 s n = GetResult (dropBits_ s n) <$> read8 s n+take8 s n = GetResult (dropBits8 s n) <$> read8 s n+ where+ --{-# INLINE read8 #-}+ read8 :: S -> Int -> IO Word8+ read8 s n | n >=0 && n <=8 =+ if n <= 8 - usedBits s+ then do -- all bits in the same byte+ w <- peek (currPtr s)+ return $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n)+ else do -- two different bytes+ w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+ return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n)+ | otherwise = badOp $ unwords ["read8: cannot read",show n,"bits"]+ -- {-# INLINE dropBits8 #-}+ -- -- Assume n <= 8+ dropBits8 :: S -> Int -> S+ dropBits8 s n =+ let u' = n+usedBits s+ in if u' < 8+ then s {usedBits=u'}+ else s {currPtr=currPtr s `plusPtr` 1,usedBits=u'-8}+++{-# INLINE takeN #-}+takeN :: (Num a, Bits a) => Int -> S -> IO (GetResult a)+takeN n s = read s 0 (n - (n `min` 8)) n+ where+ read s r sh n | n <=0 = return $ GetResult s r+ | otherwise = do+ let m = n `min` 8+ GetResult s' b <- take8 s m+ read s' (r .|. (fromIntegral b `unsafeShiftL` sh)) ((sh-8) `max` 0) (n-8)++-- takeN n = Get $ \endPtr s -> do+-- ensureBits endPtr s n+-- let (bytes,bits) = (n+usedBits s) `divMod` 8+-- r <- case bytes of+-- 0 -> do+-- w <- peek (currPtr s)+-- return . fromIntegral $ ((w `unsafeShiftL` usedBits s) `unsafeShiftR` (8 - n))+-- 1 -> do+-- w::Word16 <- toBE16 <$> peek (castPtr $ currPtr s)+-- return $ fromIntegral $ (w `unsafeShiftL` usedBits s) `unsafeShiftR` (16 - n)+-- 2 -> do+-- let r = 0+-- w1 <- fromIntegral <$> r8 s+-- w2 <- fromIntegral <$> r16 s+-- w1+-- return $ GetResult (S {currPtr=currPtr s `plusPtr` bytes,usedBits=bits}) r++-- r8 s = peek (currPtr s)+-- r16 s = toBE16 <$> peek (castPtr $ currPtr s)++-- |Return the 8 most significant bits (same as dBE8)+dWord8 :: Get Word8+dWord8 = dBE8++{-# INLINE dBE8 #-}+-- |Return the 8 most significant bits+dBE8 :: Get Word8+dBE8 = Get $ \endPtr s -> do+ ensureBits endPtr s 8+ !w1 <- peek (currPtr s)+ !w <- if usedBits s == 0+ then return w1+ else do+ !w2 <- peek (currPtr s `plusPtr` 1)+ return $ (w1 `unsafeShiftL` usedBits s) .|. (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 1}) w++{-# INLINE dBE16 #-}+-- |Return the 16 most significant bits+dBE16 :: Get Word16+dBE16 = Get $ \endPtr s -> do+ ensureBits endPtr s 16+ !w1 <- toBE16 <$> peek (castPtr $ currPtr s)+ !w <- if usedBits s == 0+ then return w1+ else do+ !(w2::Word8) <- peek (currPtr s `plusPtr` 2)+ return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 2}) w++{-# INLINE dBE32 #-}+-- |Return the 32 most significant bits+dBE32 :: Get Word32+dBE32 = Get $ \endPtr s -> do+ ensureBits endPtr s 32+ !w1 <- toBE32 <$> peek (castPtr $ currPtr s)+ !w <- if usedBits s == 0+ then return w1+ else do+ !(w2::Word8) <- peek (currPtr s `plusPtr` 4)+ return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 4}) w++{-# INLINE dBE64 #-}+-- |Return the 64 most significant bits+dBE64 :: Get Word64+dBE64 = Get $ \endPtr s -> do+ ensureBits endPtr s 64+ -- !w1 <- toBE64 <$> peek (castPtr $ currPtr s)+ !w1 <- toBE64 <$> peek64 (castPtr $ currPtr s)+ !w <- if usedBits s == 0+ then return w1+ else do+ !(w2::Word8) <- peek (currPtr s `plusPtr` 8)+ return $ w1 `unsafeShiftL` usedBits s .|. fromIntegral (w2 `unsafeShiftR` (8-usedBits s))+ return $ GetResult (s {currPtr=currPtr s `plusPtr` 8}) w+ where+ -- {-# INLINE peek64 #-}+ peek64 :: Ptr Word64 -> IO Word64+ peek64 = peek+ -- peek64 ptr = fix64 <$> peek ptr++{-# INLINE dFloat #-}+-- |Decode a Float+dFloat :: Get Float+dFloat = wordToFloat <$> dBE32++{-# INLINE dDouble #-}+-- |Decode a Double+dDouble :: Get Double+dDouble = wordToDouble <$> dBE64++-- |Decode a Lazy ByteString+dLazyByteString_ :: Get L.ByteString+dLazyByteString_ = L.fromStrict <$> dByteString_++-- |Decode a ByteString+dByteString_ :: Get B.ByteString+dByteString_ = chunksToByteString <$> getChunksInfo++-- |Decode a ByteArray and its length+dByteArray_ :: Get (ByteArray,Int)+dByteArray_ = chunksToByteArray <$> getChunksInfo++-- |Decode an Array (a list of chunks up to 255 bytes long) returning the pointer to the first data byte and a list of chunk sizes+getChunksInfo :: Get (Ptr Word8, [Int])+getChunksInfo = Get $ \endPtr s -> do++ let getChunks srcPtr l = do+ ensureBits endPtr s 8+ !n <- fromIntegral <$> peek srcPtr+ if n==0+ then return (srcPtr `plusPtr` 1,l [])+ else do+ ensureBits endPtr s ((n+1)*8)+ getChunks (srcPtr `plusPtr` (n+1)) (l . (n:)) -- ETA: stack overflow (missing tail call optimisation)++ when (usedBits s /=0) $ badEncoding endPtr s "usedBits /= 0"+ (currPtr',ns) <- getChunks (currPtr s) id+ return $ GetResult (s {currPtr=currPtr'}) (currPtr s `plusPtr` 1,ns)++{- | Given a value's decoder, returns the size in bits of the encoded value++@since 0.6+-}+sizeOf :: Get a -> Get Int+sizeOf g =+ Get $ \end s -> do+ GetResult s' _ <- runGet g end s+ return $ GetResult s' $ (currPtr s' `minusPtr` currPtr s) * 8 - usedBits s + usedBits s'++{- | Given a value's decoder, returns the value's bit encoding.++The encoding starts at the returned bit position in the return bytestring's first byte+and ends in an unspecified bit position in its final byte++@since 0.6+-}+binOf :: Get a -> Get (B.ByteString,Int)+binOf g =+ Get $ \end s -> do+ GetResult s' _ <- runGet g end s+ return $ GetResult s' (peekByteString (currPtr s) (currPtr s' `minusPtr` currPtr s + if usedBits s' == 0 then 0 else 1),usedBits s)
+ src/Flat/Decoder/Run.hs view
@@ -0,0 +1,71 @@+module Flat.Decoder.Run(strictDecoder,listTDecoder) where++import Control.Exception (Exception, try)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BS+import Flat.Decoder.Prim (dBool)+import Flat.Decoder.Types (DecodeException, Get (runGet),+ GetResult (..), S (S), tooMuchSpace)+import Foreign (Ptr, plusPtr, withForeignPtr)+import ListT (ListT (..))+import System.IO.Unsafe (unsafePerformIO)++-- | Given a decoder and an input buffer returns either the decoded value or an error (if the input buffer is not fully consumed)+strictDecoder :: Get a -> B.ByteString -> Int -> Either DecodeException a+strictDecoder get bs usedBits=+ strictDecoder_ get bs usedBits $ \(GetResult s'@(S ptr' o') a) endPtr ->+ if ptr' /= endPtr || o' /= 0+ then tooMuchSpace endPtr s'+ else return a++strictDecoder_ ::+ Exception e+ => Get a1+ -> BS.ByteString+ -> Int+ -> (GetResult a1 -> Ptr b -> IO a)+ -> Either e a+strictDecoder_ get (BS.PS base off len) usedBits check =+ unsafePerformIO . try $+ withForeignPtr base $ \base0 ->+ let ptr = base0 `plusPtr` off+ endPtr = ptr `plusPtr` len+ in do res <- runGet get endPtr (S ptr usedBits)+ check res endPtr+{-# NOINLINE strictDecoder_ #-}+++-- strictRawDecoder :: Exception e => Get t -> B.ByteString -> Either e (t,B.ByteString, NumBits)+-- strictRawDecoder get (BS.PS base off len) = unsafePerformIO . try $+-- withForeignPtr base $ \base0 ->+-- let ptr = base0 `plusPtr` off+-- endPtr = ptr `plusPtr` len+-- in do+-- GetResult (S ptr' o') a <- runGet get endPtr (S ptr 0)+-- return (a, BS.PS base (ptr' `minusPtr` base0) (endPtr `minusPtr` ptr'), o')++{-|+Decode a list of values, one value at a time.++Useful in case that the decoded values takes a lot more memory than the encoded ones.++See <../test/Big.hs> for a test and an example of use.++See also "Flat.AsBin".++@since 0.5+-}+listTDecoder :: Get a -> BS.ByteString -> IO (ListT IO a)+listTDecoder get (BS.PS base off len) =+ withForeignPtr base $ \base0 -> do+ let ptr = base0 `plusPtr` off+ endPtr = ptr `plusPtr` len+ s = S ptr 0+ go s = do+ GetResult s' b <- runGet dBool endPtr s+ if b+ then do+ GetResult s'' a <- runGet get endPtr s'+ return $ Just (a, ListT $ go s'')+ else return Nothing+ return $ ListT (go s)
+ src/Flat/Decoder/Strict.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-- |Strict Decoder+module Flat.Decoder.Strict+ ( decodeArrayWith+ , decodeListWith+ , dByteString+ , dLazyByteString+ , dShortByteString+ , dShortByteString_+#if! defined (ETA_VERSION)+ , dUTF16+#endif+ , dUTF8+ , dInteger+ , dNatural+ , dChar+ , dWord8+ , dWord16+ , dWord32+ , dWord64+ , dWord+ , dInt8+ , dInt16+ , dInt32+ , dInt64+ , dInt+ ) where++import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS+#if !MIN_VERSION_bytestring(0,11,0)+import qualified Data.ByteString.Short.Internal as SBS+#endif+import Control.Monad (unless)+import qualified Data.DList as DL+import Data.Int+import Data.Primitive.ByteArray+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Flat.Decoder.Prim+import Flat.Decoder.Types++#if! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0)+import qualified Data.Text.Array as TA+import qualified Data.Text.Internal as T+#endif++import Data.Word+import Data.ZigZag+import GHC.Base (unsafeChr)+import Numeric.Natural (Natural)+#include "MachDeps.h"++{-# INLINE decodeListWith #-}+decodeListWith :: Get a -> Get [a]+decodeListWith dec = go+ where+ go = do+ b <- dBool+ if b+ then (:) <$> dec <*> go+ else return []++decodeArrayWith :: Get a -> Get [a]+decodeArrayWith dec = DL.toList <$> getAsL_ dec++-- TODO: test if it would it be faster with DList.unfoldr :: (b -> Maybe (a, b)) -> b -> Data.DList.DList a+-- getAsL_ :: Flat a => Get (DL.DList a)+getAsL_ :: Get a -> Get (DL.DList a)+getAsL_ dec = do+ tag <- dWord8+ case tag of+ 0 -> return DL.empty+ _ -> do+ h <- gets tag+ t <- getAsL_ dec+ return (DL.append h t)+ where+ gets 0 = return DL.empty+ gets n = DL.cons <$> dec <*> gets (n - 1)++{-# INLINE dNatural #-}+dNatural :: Get Natural+dNatural = dUnsigned++{-# INLINE dInteger #-}+dInteger :: Get Integer+dInteger = zagZig <$> dUnsigned++{-# INLINE dWord #-}+{-# INLINE dInt #-}+dWord :: Get Word+dInt :: Get Int++#if WORD_SIZE_IN_BITS == 64+dWord = (fromIntegral :: Word64 -> Word) <$> dWord64++dInt = (fromIntegral :: Int64 -> Int) <$> dInt64+#elif WORD_SIZE_IN_BITS == 32+dWord = (fromIntegral :: Word32 -> Word) <$> dWord32++dInt = (fromIntegral :: Int32 -> Int) <$> dInt32+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif+++++++++{-# INLINE dInt8 #-}+dInt8 :: Get Int8+dInt8 = zagZig <$> dWord8++{-# INLINE dInt16 #-}+dInt16 :: Get Int16+dInt16 = zagZig <$> dWord16++{-# INLINE dInt32 #-}+dInt32 :: Get Int32+dInt32 = zagZig <$> dWord32++{-# INLINE dInt64 #-}+dInt64 :: Get Int64+dInt64 = zagZig <$> dWord64++-- {-# INLINE dWord16 #-}+dWord16 :: Get Word16+dWord16 = wordStep 0 (wordStep 7 (lastStep 14)) 0++-- {-# INLINE dWord32 #-}+dWord32 :: Get Word32+dWord32 = wordStep 0 (wordStep 7 (wordStep 14 (wordStep 21 (lastStep 28)))) 0++-- {-# INLINE dWord64 #-}+dWord64 :: Get Word64+dWord64 =+ wordStep+ 0+ (wordStep+ 7+ (wordStep+ 14+ (wordStep+ 21+ (wordStep+ 28+ (wordStep+ 35+ (wordStep+ 42+ (wordStep+ 49+ (wordStep 56 (lastStep 63)))))))))+ 0++{-# INLINE dChar #-}+dChar :: Get Char+-- dChar = chr . fromIntegral <$> dWord32+-- Not really faster than the simpler version above+dChar = charStep 0 (charStep 7 (lastCharStep 14)) 0++{-# INLINE charStep #-}+charStep :: Int -> (Int -> Get Char) -> Int -> Get Char+charStep !shl !cont !n = do+ !tw <- fromIntegral <$> dWord8+ let !w = tw .&. 127+ let !v = n .|. w `shift` shl+ if tw == w+ then return $ unsafeChr v+ else cont v++{-# INLINE lastCharStep #-}+lastCharStep :: Int -> Int -> Get Char+lastCharStep !shl !n = do+ !tw <- fromIntegral <$> dWord8+ let !w = tw .&. 127+ let !v = n .|. w `shift` shl+ if tw == w+ then if v > 0x10FFFF+ then charErr v+ else return $ unsafeChr v+ else charErr v+ where+ charErr v = fail $ "Unexpected extra byte or non unicode char" ++ show v++{-# INLINE wordStep #-}+wordStep :: (Bits a, Num a) => Int -> (a -> Get a) -> a -> Get a+wordStep shl k n = do+ tw <- fromIntegral <$> dWord8+ let w = tw .&. 127+ let v = n .|. w `shift` shl+ if tw == w+ then return v+ --else oneShot k v+ else k v++{-# INLINE lastStep #-}+lastStep :: (FiniteBits b, Show b, Num b) => Int -> b -> Get b+lastStep shl n = do+ tw <- fromIntegral <$> dWord8+ let w = tw .&. 127+ let v = n .|. w `shift` shl+ if tw == w+ then if countLeadingZeros w < shl+ then wordErr v+ else return v+ else wordErr v+ where+ wordErr v = fail $ "Unexpected extra byte in unsigned integer" ++ show v++-- {-# INLINE dUnsigned #-}+dUnsigned :: (Num b, Bits b) => Get b+dUnsigned = do+ (v, shl) <- dUnsigned_ 0 0+ maybe+ (return v)+ (\s ->+ if shl >= s+ then fail "Unexpected extra data in unsigned integer"+ else return v) $+ bitSizeMaybe v++-- {-# INLINE dUnsigned_ #-}+dUnsigned_ :: (Bits t, Num t) => Int -> t -> Get (t, Int)+dUnsigned_ shl n = do+ tw <- dWord8+ let w = tw .&. 127+ let v = n .|. fromIntegral w `shift` shl+ if tw == w+ then return (v, shl)+ else dUnsigned_ (shl + 7) v++--encode = encode . blob UTF8Encoding . L.fromStrict . T.encodeUtf8+--decode = T.decodeUtf8 . L.toStrict . (unblob :: BLOB UTF8Encoding -> L.ByteString) <$> decode++#if ! defined (ETA_VERSION)+-- BLOB UTF16Encoding+dUTF16 :: Get T.Text+dUTF16 = do+ _ <- dFiller+#if MIN_VERSION_text(2,0,0)+ -- Checked decoding (from UTF-8)+ T.decodeUtf16LE <$> dByteString_+#else+ -- Unchecked decoding (already UTF16)+ (ByteArray array, lengthInBytes) <- dByteArray_+ return (T.Text (TA.Array array) 0 (lengthInBytes `div` 2))+#endif+#endif++dUTF8 :: Get T.Text+dUTF8 = do+ _ <- dFiller+ bs <- dByteString_+ case T.decodeUtf8' bs of+ Right t -> pure t+ Left e -> fail $ "Input contains invalid UTF-8 data" ++ show e++dFiller :: Get ()+dFiller = do+ tag <- dBool+ unless tag dFiller++dLazyByteString :: Get L.ByteString+dLazyByteString = dFiller >> dLazyByteString_++dShortByteString :: Get SBS.ShortByteString+dShortByteString = dFiller >> dShortByteString_++dShortByteString_ :: Get SBS.ShortByteString+dShortByteString_ = do+ (ByteArray array, _) <- dByteArray_+ return $ SBS.SBS array++dByteString :: Get B.ByteString+dByteString = dFiller >> dByteString_++++
+ src/Flat/Decoder/Types.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++-- |Strict Decoder Types+module Flat.Decoder.Types+ (+ Get(..)+ , S(..)+ , GetResult(..)+ , Decoded+ , DecodeException(..)+ , notEnoughSpace+ , tooMuchSpace+ , badEncoding+ , badOp+ ) where++import Control.DeepSeq (NFData (..))+import Control.Exception (Exception, throwIO)+import Data.Word (Word8)+import Foreign (Ptr)++#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif++{- |+A decoder.++Given:++* end of input buffer++* current position in input buffer++Returns:++* decoded value++* new position in input buffer+-}+newtype Get a =+ Get+ { runGet ::+ Ptr Word8+ -> S+ -> IO (GetResult a)+ }++-- Seems to give better performance than the derived version+instance Functor Get where+ fmap f g =+ Get $ \end s -> do+ GetResult s' a <- runGet g end s+ return $ GetResult s' (f a)+ {-# INLINE fmap #-}++-- Is this correct?+instance NFData (Get a) where+ rnf !_ = ()++instance Show (Get a) where+ show _ = "Get"++instance Applicative Get where+ pure x = Get (\_ ptr -> return $ GetResult ptr x)+ {-# INLINE pure #-}+ Get f <*> Get g =+ Get $ \end ptr1 -> do+ GetResult ptr2 f' <- f end ptr1+ GetResult ptr3 g' <- g end ptr2+ return $ GetResult ptr3 (f' g')+ {-# INLINE (<*>) #-}+ Get f *> Get g =+ Get $ \end ptr1 -> do+ GetResult ptr2 _ <- f end ptr1+ g end ptr2+ {-# INLINE (*>) #-}++instance Monad Get where+ return = pure+ {-# INLINE return #-}+ (>>) = (*>)+ {-# INLINE (>>) #-}+ Get x >>= f =+ Get $ \end s -> do+ GetResult s' x' <- x end s+ runGet (f x') end s'+ {-# INLINE (>>=) #-}+#if !(MIN_VERSION_base(4,13,0))+ fail = failGet+#endif++#if MIN_VERSION_base(4,9,0)+instance Fail.MonadFail Get where+ fail = failGet+#endif+{-# INLINE failGet #-}+failGet :: String -> Get a+failGet msg = Get $ \end s -> badEncoding end s msg++-- |Decoder state+data S =+ S+ { currPtr :: {-# UNPACK #-}!(Ptr Word8)+ , usedBits :: {-# UNPACK #-}!Int+ }+ deriving (Show, Eq, Ord)++data GetResult a =+ GetResult {-# UNPACK #-}!S !a+ deriving (Functor)++-- |A decoded value+type Decoded a = Either DecodeException a++-- |An exception during decoding+data DecodeException+ = NotEnoughSpace Env+ | TooMuchSpace Env+ | BadEncoding Env String+ | BadOp String+ deriving (Show, Eq, Ord)++type Env = (Ptr Word8, S)++notEnoughSpace :: Ptr Word8 -> S -> IO a+notEnoughSpace endPtr s = throwIO $ NotEnoughSpace (endPtr, s)++tooMuchSpace :: Ptr Word8 -> S -> IO a+tooMuchSpace endPtr s = throwIO $ TooMuchSpace (endPtr, s)++badEncoding :: Ptr Word8 -> S -> String -> IO a+badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr, s) msg++badOp :: String -> IO a+badOp msg = throwIO $ BadOp msg++instance Exception DecodeException
+ src/Flat/Encoder.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+-- |Encoder and encoding primitives+module Flat.Encoder (+ Encoding,+ (<>),+ NumBits,+ encodersS,+ mempty,+ strictEncoder,+ eTrueF,+ eFalseF,+ eFloat,+ eDouble,+ eInteger,+ eNatural,+ eWord16,+ eWord32,+ eWord64,+ eWord8,+ eBits,+ eBits16,+ eFiller,+ eBool,+ eTrue,+ eFalse,+ eBytes,+#if ! defined (ETA_VERSION)+ eUTF16,+#endif+ eLazyBytes,+ eShortBytes,+ eInt,+ eInt8,+ eInt16,+ eInt32,+ eInt64,+ eWord,+ eChar,+ encodeArrayWith,+ encodeListWith,+ Size,+ arrayBits,+ sWord,+ sWord8,+ sWord16,+ sWord32,+ sWord64,+ sInt,+ sInt8,+ sInt16,+ sInt32,+ sInt64,+ sNatural,+ sInteger,+ sFloat,+ sDouble,+ sChar,+ sBytes,+ sLazyBytes,+ sShortBytes,+ sUTF16,+ sFillerMax,+ sBool,+ sUTF8Max,+ eUTF8,+#ifdef ETA_VERSION+ trampolineEncoding,+#endif+ ) where++import Flat.Encoder.Prim (eFalseF, eTrueF)+import Flat.Encoder.Size (arrayBits)+import Flat.Encoder.Strict+import Flat.Encoder.Types (NumBits, Size)++#if ! MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif
+ src/Flat/Encoder/Prim.hs view
@@ -0,0 +1,541 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |Encoding Primitives+module Flat.Encoder.Prim+ (+ -- Primitives whose name starts with 'e' encode a value in place+ eBits16F+ , eBitsF+ , eFloatF+ , eDoubleF+#if ! defined (ETA_VERSION)+ , eUTF16F+#endif+ , eUTF8F+ , eCharF+ , eNaturalF+ , eIntegerF+ , eInt64F+ , eInt32F+ , eIntF+ , eInt16F+ , eInt8F+ , eWordF+ , eWord64F+ , eWord32F+ , eWord16F+ , eBytesF+ , eLazyBytesF+ , eShortBytesF+ , eWord8F+ , eFillerF+ , eBoolF+ , eTrueF+ , eFalseF++ , varWordF++ , updateWord8+ , w7l++ -- * Exported for testing only+ , eWord32BEF+ , eWord64BEF+ , eWord32E+ , eWord64E+ ) where++import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.ByteString.Short.Internal as SBS+import Data.Char+import Data.FloatCast+import Data.Primitive.ByteArray+import qualified Data.Text as T+import Flat.Encoder.Types+import Flat.Endian+import Flat.Memory+import Flat.Types++#if ! defined (ETA_VERSION) && ! MIN_VERSION_text(2,0,0)+import qualified Data.Text.Array as TA+import qualified Data.Text.Internal as TI+-- import Data.FloatCast+-- import Data.Primitive.ByteArray+-- import qualified Data.Text as T+#endif+import qualified Data.Text.Encoding as TE+import Data.ZigZag+import Foreign+-- import Debug.Trace+#include "MachDeps.h"+-- traceShowId :: a -> a+-- traceShowId = id++-- $setup+-- >>> import Flat.Instances.Test+-- >>> import Flat.Bits+-- >>> import Flat.Encoder.Strict+-- >>> import Control.Monad+-- >>> let enc e = prettyShow $ encBits 256 (Encoding e)++{-# INLINE eFloatF #-}+eFloatF :: Float -> Prim+eFloatF = eWord32BEF . floatToWord++{-# INLINE eDoubleF #-}+eDoubleF :: Double -> Prim+eDoubleF = eWord64BEF . doubleToWord++{-# INLINE eWord64BEF #-}+eWord64BEF :: Word64 -> Prim+eWord64BEF = eWord64E toBE64++{-# INLINE eWord32BEF #-}+eWord32BEF :: Word32 -> Prim+eWord32BEF = eWord32E toBE32++{-# INLINE eCharF #-}+eCharF :: Char -> Prim+eCharF = eWord32F . fromIntegral . ord++{-# INLINE eWordF #-}+eWordF :: Word -> Prim+{-# INLINE eIntF #-}+eIntF :: Int -> Prim++#if WORD_SIZE_IN_BITS == 64+eWordF = eWord64F . (fromIntegral :: Word -> Word64)++eIntF = eInt64F . (fromIntegral :: Int -> Int64)+#elif WORD_SIZE_IN_BITS == 32+eWordF = eWord32F . (fromIntegral :: Word -> Word32)++eIntF = eInt32F . (fromIntegral :: Int -> Int32)+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif++{-# INLINE eInt8F #-}+eInt8F :: Int8 -> Prim+eInt8F = eWord8F . zigZag++{-# INLINE eInt16F #-}+eInt16F :: Int16 -> Prim+eInt16F = eWord16F . zigZag++{-# INLINE eInt32F #-}+eInt32F :: Int32 -> Prim+eInt32F = eWord32F . zigZag++{-# INLINE eInt64F #-}+eInt64F :: Int64 -> Prim+eInt64F = eWord64F . zigZag++{-# INLINE eIntegerF #-}+eIntegerF :: Integer -> Prim+eIntegerF = eIntegralF . zigZag++{-# INLINE eNaturalF #-}+eNaturalF :: Natural -> Prim+eNaturalF = eIntegralF . toInteger++{-# INLINE eIntegralF #-}+eIntegralF :: (Bits t, Integral t) => t -> Prim+eIntegralF t =+ let vs = w7l t+ in eIntegralW vs++w7l :: (Bits t, Integral t) => t -> [Word8]+w7l t =+ let l = low7 t+ t' = t `unsafeShiftR` 7+ in if t' == 0+ then [l]+ else w7 l : w7l t'+ where+ {-# INLINE w7 #-}+ --lowByte :: (Bits t, Num t) => t -> Word8+ w7 :: Word8 -> Word8+ w7 l = l .|. 0x80++-- | Encoded as: data NonEmptyList = Elem Word7 | Cons Word7 List+{-# INLINE eIntegralW #-}+eIntegralW :: [Word8] -> Prim+eIntegralW vs s@(S op _ o)+ | o == 0 = foldM pokeWord' op vs >>= \op' -> return (S op' 0 0)+ | otherwise = foldM (flip eWord8F) s vs++{-+>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 0 s1 >>= \s2 -> eTrueF s2+"10000000 01"+-}++{-# INLINE eWord8F #-}+eWord8F :: Word8 -> Prim+eWord8F t s@(S op _ o)+ | o == 0 = pokeWord op t+ | otherwise = eByteUnaligned t s++{-# INLINE eWord32E #-}+eWord32E :: (Word32 -> Word32) -> Word32 -> Prim+eWord32E conv t (S op w o)+ | o == 0 = pokeW conv op t >> skipBytes op 4+ | otherwise =+ pokeW conv op (asWord32 w `unsafeShiftL` 24 .|. t `unsafeShiftR` o) >>+ return (S (plusPtr op 4) (asWord8 t `unsafeShiftL` (8 - o)) o)++{-# INLINE eWord64E #-}+eWord64E :: (Word64 -> Word64) -> Word64 -> Prim+eWord64E conv t (S op w o)+ | o == 0 = poke64 conv op t >> skipBytes op 8+ | otherwise =+ poke64 conv op (asWord64 w `unsafeShiftL` 56 .|. t `unsafeShiftR` o) >>+ return (S (plusPtr op 8) (asWord8 t `unsafeShiftL` (8 - o)) o)++{-# INLINE eWord16F #-}+eWord16F :: Word16 -> Prim+eWord16F = varWordF++{-# INLINE eWord32F #-}+eWord32F :: Word32 -> Prim+eWord32F = varWordF++{-# INLINE eWord64F #-}+eWord64F :: Word64 -> Prim+eWord64F = varWordF++{-# INLINE varWordF #-}+varWordF :: (Bits t, Integral t) => t -> Prim+varWordF t s@(S _ _ o)+ | o == 0 = varWord eByteAligned t s+ | otherwise = varWord eByteUnaligned t s++{-# INLINE varWord #-}+varWord :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim+varWord writeByte t s+ | t < 128 = writeByte (fromIntegral t) s+ | t < 16384 = varWord2_ writeByte t s+ | t < 2097152 = varWord3_ writeByte t s+ | otherwise = varWordN_ writeByte t s+ where+ {-# INLINE varWord2_ #-}+ -- TODO: optimise, using a single Write16?+ varWord2_ writeByte t s =+ writeByte (fromIntegral t .|. 0x80) s >>=+ writeByte (fromIntegral (t `unsafeShiftR` 7) .&. 0x7F)+ {-# INLINE varWord3_ #-}+ varWord3_ writeByte t s =+ writeByte (fromIntegral t .|. 0x80) s >>=+ writeByte (fromIntegral (t `unsafeShiftR` 7) .|. 0x80) >>=+ writeByte (fromIntegral (t `unsafeShiftR` 14) .&. 0x7F)++-- {-# INLINE varWordN #-}+varWordN_ :: (Bits t, Integral t) => (Word8 -> Prim) -> t -> Prim+varWordN_ writeByte = go+ where+ go !v !st =+ let !l = low7 v+ !v' = v `unsafeShiftR` 7+ in if v' == 0+ then writeByte l st+ else writeByte (l .|. 0x80) st >>= go v'++{-# INLINE low7 #-}+low7 :: (Integral a) => a -> Word8+low7 t = fromIntegral t .&. 0x7F++-- | Encode text as UTF8 and encode the result as an array of bytes+eUTF8F :: T.Text -> Prim+eUTF8F = eBytesF . TE.encodeUtf8++-- | Encode text as UTF16 and encode the result as an array of bytes+#if ! defined (ETA_VERSION)+eUTF16F :: T.Text -> Prim+#if MIN_VERSION_text(2,0,0)+eUTF16F = eBytesF . TE.encodeUtf16LE+#else+eUTF16F t = eFillerF >=> eUTF16F_ t+ where+ eUTF16F_ (TI.Text (TA.Array array) w16Off w16Len) s =+ writeArray array (2 * w16Off) (2 * w16Len) (nextPtr s)+#endif+#endif++-- |Encode a Lazy ByteString+eLazyBytesF :: L.ByteString -> Prim+eLazyBytesF bs = eFillerF >=> \s -> write bs (nextPtr s)+ -- Single copy+ where+ write lbs op = do+ case lbs of+ L.Chunk h t -> writeBS h op >>= write t+ L.Empty -> pokeWord op 0++{-# INLINE eShortBytesF #-}+eShortBytesF :: SBS.ShortByteString -> Prim+eShortBytesF bs = eFillerF >=> eShortBytesF_ bs+ where+ eShortBytesF_ :: SBS.ShortByteString -> Prim+ eShortBytesF_ bs@(SBS.SBS arr) (S op _ 0) = writeArray arr 0 (SBS.length bs) op+ eShortBytesF_ _ _ = error "impossible"++-- data Array a = Array0 | Array1 a ... | Array255 ...+writeArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO S+writeArray arr soff slen sop = do+ op' <- go soff slen sop+ pokeWord op' 0+ where+ go !off !len !op+ | len == 0 = return op+ | otherwise =+ let l = min 255 len+ in pokeWord' op (fromIntegral l) >>= pokeByteArray arr off l >>=+ go (off + l) (len - l)++eBytesF :: B.ByteString -> Prim+eBytesF bs = eFillerF >=> eBytesF_+ where+ eBytesF_ s = do+ op' <- writeBS bs (nextPtr s)+ pokeWord op' 0++-- |Encode up to 9 bits+{-# INLINE eBits16F #-}+eBits16F :: NumBits -> Word16 -> Prim+--eBits16F numBits code | numBits >8 = eBitsF (numBits-8) (fromIntegral $ code `unsafeShiftR` 8) >=> eBitsF 8 (fromIntegral code)+-- eBits16F _ _ = eFalseF+eBits16F 9 code =+ eBitsF 1 (fromIntegral $ code `unsafeShiftR` 8) >=>+ eBitsF_ 8 (fromIntegral code)+eBits16F numBits code = eBitsF numBits (fromIntegral code)++-- |Encode up to 8 bits.+{-# INLINE eBitsF #-}+eBitsF :: NumBits -> Word8 -> Prim+eBitsF 1 0 = eFalseF+eBitsF 1 1 = eTrueF+eBitsF 2 0 = eFalseF >=> eFalseF+eBitsF 2 1 = eFalseF >=> eTrueF+eBitsF 2 2 = eTrueF >=> eFalseF+eBitsF 2 3 = eTrueF >=> eTrueF+eBitsF n t = eBitsF_ n t++{-+eBits Example:+Before:+n = 6+t = 00.101011+o = 3+w = 111.00000++After:+[ptr] = w(111)t(10101)+w' = t(1)0000000+o'= 1++o'=3+6=9+f = 8-9 = -1+o'' = 1+8-o''=7++if n=8,o=3:+o'=11+f=8-11=-3+o''=3+8-o''=5+-}+-- {-# NOINLINE eBitsF_ #-}+eBitsF_ :: NumBits -> Word8 -> Prim+eBitsF_ n t (S op w o) =+ let o' = o + n -- used bits+ f = 8 - o' -- remaining free bits+ in if | f > 0 -> return $ S op (w .|. (t `unsafeShiftL` f)) o'+ | f == 0 -> pokeWord op (w .|. t)+ | otherwise ->+ let o'' = -f+ in poke op (w .|. (t `unsafeShiftR` o'')) >>+ return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o'')) o'')++{-# INLINE eBoolF #-}+eBoolF :: Bool -> Prim+eBoolF False = eFalseF+eBoolF True = eTrueF++-- | >>> enc eTrueF+-- "1"+{-# INLINE eTrueF #-}+eTrueF :: Prim+eTrueF (S op w o)+ | o == 7 = pokeWord op (w .|. 1)+ | otherwise = return (S op (w .|. 128 `unsafeShiftR` o) (o + 1))++-- | >>> enc eFalseF+-- "0"+{-# INLINE eFalseF #-}+eFalseF :: Prim+eFalseF (S op w o)+ | o == 7 = pokeWord op w+ | otherwise = return (S op w (o + 1))++{- |++>>> enc $ eTrueF >=> eFillerF+"10000001"++>>> enc eFillerF+"00000001"+-}+{-# INLINE eFillerF #-}+eFillerF :: Prim+eFillerF (S op w _) = pokeWord op (w .|. 1)++-- {-# INLINE poke16 #-}+-- TODO TEST+-- poke16 :: Word16 -> Prim+-- poke16 t (S op w o) | o == 0 = poke op w >> skipBytes op 2+{-+To be used only when usedBits /= 0++>>> enc (eFalseF >=> eFalseF >=> eByteUnaligned 255)+"00111111 11"+-}+{-# INLINE eByteUnaligned #-}+eByteUnaligned :: Word8 -> Prim+eByteUnaligned t (S op w o) =+ poke op (w .|. (t `unsafeShiftR` o)) >>+ return (S (plusPtr op 1) (t `unsafeShiftL` (8 - o)) o)++{- To be used only when usedBits = 0++>>> enc (eFalseF >=> eFalseF >=> eFalseF >=> eByteAligned 255)+"11111111"+-}+{-# INLINE eByteAligned #-}+eByteAligned :: Word8 -> Prim+eByteAligned t (S op _ _) = pokeWord op t++{-|+>>> enc $ \s-> eWord8F 0 s >>= updateWord8 255 s+"11111111"++>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eWord8F 255 >>= updateWord8 0 s1+"10000000 01111111 1"++>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1+"01111111 1"++>>> enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 >>= eFalseF+"01111111 10"++>>> enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eTrueF >>= updateWord8 0 s1 >>= eTrueF+"10000000 011"++@since 0.5+-}+updateWord8 :: Word8 -> S -> Prim+updateWord8 t mem s = do+ uncache s+ pokeWord8 t mem+ cache s++uncache :: S -> IO ()+uncache s = poke (nextPtr s) (currByte s)++cache :: Prim+cache s = do+ w <- (mask s .&.) <$> peek (nextPtr s)+ return $ s {currByte = w}++mask :: S -> Word8+mask s = 255 `unsafeShiftL` (8 - usedBits s)++{-# INLINE pokeWord8 #-}+pokeWord8 :: Word8 -> S -> IO ()+pokeWord8 t (S op _ 0) = poke op t+pokeWord8 t (S op w o) = do+ poke op (w .|. (t `unsafeShiftR` o))+ let op' :: Ptr Word8 = plusPtr op 1+ v :: Word8 <- peek op'+ poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o))++-- | o == 0 = pokeByteAligned t s+-- | otherwise = pokeByteUnaligned t s+-- where+-- {-# INLINE pokeByteUnaligned #-}+-- pokeByteUnaligned :: Word8 -> S -> IO ()+-- pokeByteUnaligned t (S op w o) = do+-- let op' = plusPtr op 1+-- poke op (w .|. (t `unsafeShiftR` o))+-- v :: Word8 <- peek op'+-- poke op' (t `unsafeShiftL` (8 - o) .|. ((v `unsafeShiftL` o) `unsafeShiftR` o))++-- {-# INLINE pokeByteAligned #-}+-- pokeByteAligned :: Word8 -> S -> IO ()+-- pokeByteAligned t (S op _ _) = poke op t++-- FIX: not really pokes++{-# INLINE pokeWord #-}+pokeWord :: Storable a => Ptr a -> a -> IO S+pokeWord op w = poke op w >> skipByte op++{-# INLINE pokeWord' #-}+pokeWord' :: Storable a => Ptr a -> a -> IO (Ptr b)+pokeWord' op w = poke op w >> return (plusPtr op 1)++{-# INLINE pokeW #-}+pokeW :: Storable a => (t -> a) -> Ptr a1 -> t -> IO ()+pokeW conv op t = poke (castPtr op) (conv t)++{-# INLINE poke64 #-}+poke64 :: (t -> Word64) -> Ptr a -> t -> IO ()+poke64 conv op t = poke (castPtr op) (conv t)+-- poke64 conv op t = poke (castPtr op) (fix64 . conv $ t)++{-# INLINE skipByte #-}+skipByte :: Monad m => Ptr a -> m S+skipByte op = return (S (plusPtr op 1) 0 0)++{-# INLINE skipBytes #-}+skipBytes :: Monad m => Ptr a -> Int -> m S+skipBytes op n = return (S (plusPtr op n) 0 0)++--{-# INLINE nextByteW #-}+--nextByteW op w = return (S (plusPtr op 1) 0 0)+writeBS :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)+writeBS bs op -- @(BS.PS foreignPointer sourceOffset sourceLength) op+ | B.length bs == 0 = return op+ | otherwise =+ let (h, t) = B.splitAt 255 bs+ in pokeWord' op (fromIntegral $ B.length h :: Word8) >>= pokeByteString h >>=+ writeBS t+ -- 2X slower (why?)+ -- withForeignPtr foreignPointer goS+ -- where+ -- goS sourcePointer = go op (sourcePointer `plusPtr` sourceOffset) sourceLength+ -- where+ -- go !op !off !len | len == 0 = return op+ -- | otherwise = do+ -- let l = min 255 len+ -- op' <- pokeWord' op (fromIntegral l)+ -- BS.memcpy op' off l+ -- go (op' `plusPtr` l) (off `plusPtr` l) (len-l)++{-# INLINE asWord64 #-}+asWord64 :: Integral a => a -> Word64+asWord64 = fromIntegral++{-# INLINE asWord32 #-}+asWord32 :: Integral a => a -> Word32+asWord32 = fromIntegral++{-# INLINE asWord8 #-}+asWord8 :: Integral a => a -> Word8+asWord8 = fromIntegral
+ src/Flat/Encoder/Size.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}++-- |Primitives to calculate the maximum size in bits of the encoding of a value+module Flat.Encoder.Size where++import Data.Bits (Bits)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short.Internal as SBS+import Data.Char (ord)+import qualified Data.Text as T+import qualified Data.Text.Internal as TI+import Data.ZigZag (ZigZag (zigZag))+import Flat.Encoder.Prim (w7l)+import Flat.Types (Int16, Int32, Int64, Natural,+ NumBits, Text, Word16, Word32,+ Word64)+#include "MachDeps.h"+-- A filler can take anything from 1 to 8 bits+sFillerMax :: NumBits+sFillerMax = 8++sBool :: NumBits+sBool = 1++sWord8 :: NumBits+sWord8 = 8++sInt8 :: NumBits+sInt8 = 8++sFloat :: NumBits+sFloat = 32++sDouble :: NumBits+sDouble = 64++{-# INLINE sChar #-}+sChar :: Char -> NumBits+sChar = sWord32 . fromIntegral . ord++sCharMax :: NumBits+sCharMax = 24++{-# INLINE sWord #-}+sWord :: Word -> NumBits+{-# INLINE sInt #-}+sInt :: Int -> NumBits+#if WORD_SIZE_IN_BITS == 64+sWord = sWord64 . fromIntegral++sInt = sInt64 . fromIntegral+#elif WORD_SIZE_IN_BITS == 32+sWord = sWord32 . fromIntegral++sInt = sInt32 . fromIntegral+#else+#error expected WORD_SIZE_IN_BITS to be 32 or 64+#endif+-- TODO: optimize ints sizes+{-# INLINE sInt16 #-}+sInt16 :: Int16 -> NumBits+sInt16 = sWord16 . zigZag++{-# INLINE sInt32 #-}+sInt32 :: Int32 -> NumBits+sInt32 = sWord32 . zigZag++{-# INLINE sInt64 #-}+sInt64 :: Int64 -> NumBits+sInt64 = sWord64 . zigZag++{-# INLINE sWord16 #-}+sWord16 :: Word16 -> NumBits+sWord16 w+ | w < 128 = 8+ | w < 16384 = 16+ | otherwise = 24++{-# INLINE sWord32 #-}+sWord32 :: Word32 -> NumBits+sWord32 w+ | w < 128 = 8+ | w < 16384 = 16+ | w < 2097152 = 24+ | w < 268435456 = 32+ | otherwise = 40++{-# INLINE sWord64 #-}+sWord64 :: Word64 -> NumBits+sWord64 w+ | w < 128 = 8+ | w < 16384 = 16+ | w < 2097152 = 24+ | w < 268435456 = 32+ | w < 34359738368 = 40+ | w < 4398046511104 = 48+ | w < 562949953421312 = 56+ | w < 72057594037927936 = 64+ | w < 9223372036854775808 = 72+ | otherwise = 80++{-# INLINE sInteger #-}+sInteger :: Integer -> NumBits+sInteger = sIntegral . zigZag++{-# INLINE sNatural #-}+sNatural :: Natural -> NumBits+sNatural = sIntegral . toInteger++-- BAD: duplication of work with encoding+{-# INLINE sIntegral #-}+sIntegral :: (Bits t, Integral t) => t -> Int+sIntegral t =+ let vs = w7l t+ in length vs * 8++{-# INLINE sUTF8Max #-}+sUTF8Max :: Text -> NumBits+sUTF8Max (TI.Text _ _ lenInUnits) =+ let len =+#if MIN_VERSION_text(2,0,0)+ -- UTF-8 encoding, units are bytes+ lenInUnits+#else+ -- UTF-16 encoding, units are 16 bits words+ -- worst case: a utf-16 unit becomes a 3 bytes utf-8 encoding+ lenInUnits * 3+#endif+ in blobBits len++{-# INLINE sUTF16Max #-}+sUTF16Max :: T.Text -> NumBits+sUTF16Max (TI.Text _ _ lenInUnits) =+ let len =+#if MIN_VERSION_text(2,0,0)+ -- UTF-8 encoding+ -- worst case, a 1 byte UTF-8 char becomes a 2 bytes UTF-16 (ascii)+ lenInUnits * 2+#else+ -- UTF-16 encoding+ lenInUnits * 2+#endif+ in blobBits len++{-# INLINE sBytes #-}+sBytes :: B.ByteString -> NumBits+sBytes = blobBits . B.length++{-# INLINE sLazyBytes #-}+sLazyBytes :: L.ByteString -> NumBits+sLazyBytes bs = 16 + L.foldrChunks (\b l -> blkBitsBS b + l) 0 bs++{-# INLINE sShortBytes #-}+sShortBytes :: SBS.ShortByteString -> NumBits+sShortBytes = blobBits . SBS.length++{-# INLINE bitsToBytes #-}+bitsToBytes :: Int -> Int+bitsToBytes = numBlks 8++{-# INLINE numBlks #-}+numBlks :: Integral t => t -> t -> t+numBlks blkSize bits =+ let (d, m) = bits `divMod` blkSize+ in d ++ (if m == 0+ then 0+ else 1)++{-# INLINE arrayBits #-}+arrayBits :: Int -> NumBits+arrayBits = (8 *) . arrayChunks++{-# INLINE arrayChunks #-}+arrayChunks :: Int -> NumBits+arrayChunks = (1 +) . numBlks 255++{-# INLINE blobBits #-}+blobBits :: Int -> NumBits+blobBits numBytes =+ 16 -- initial filler + final 0+ ++ blksBits numBytes++{-# INLINE blkBitsBS #-}+blkBitsBS :: B.ByteString -> NumBits+blkBitsBS = blksBits . B.length++{-# INLINE blksBits #-}+blksBits :: Int -> NumBits+blksBits numBytes = 8 * (numBytes + numBlks 255 numBytes)
+ src/Flat/Encoder/Strict.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |Strict encoder+module Flat.Encoder.Strict where++import Control.Monad (when)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Foldable+import Flat.Encoder.Prim+import qualified Flat.Encoder.Size as S+import Flat.Encoder.Types+import Flat.Memory+import Flat.Types++-- import Data.Semigroup+-- import Data.Semigroup (Semigroup (..))++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++#ifdef ETA_VERSION+-- import Data.Function(trampoline)+import GHC.IO (trampolineIO)+trampolineEncoding :: Encoding -> Encoding+trampolineEncoding (Encoding op) = Encoding (\s -> trampolineIO (op s))+#else++-- trampolineIO = id+#endif++-- |Strict encoder+strictEncoder :: NumBits -> Encoding -> B.ByteString+strictEncoder numBits enc =+ let (bs,numBitsUsed) = strictEncoderPartial numBits enc+ bitsInLastByte = numBitsUsed `mod` 8+ in if bitsInLastByte /=0+ then error $ unwords ["encoder: did not end on byte boundary, bits used in last byte=",show bitsInLastByte]+ else bs++numEncodedBits :: Int -> Encoding -> NumBits+numEncodedBits numBits enc =snd $ strictEncoderPartial numBits enc++strictEncoderPartial ::+ Int -- ^ the maximum size in bits of the encoding+ -> Encoding -- ^ the encoder+ -> (B.ByteString, NumBits) -- ^ the encoded bytestring + the actual number of encoded bits+strictEncoderPartial numBits (Encoding op)+ = let bufSize = S.bitsToBytes numBits+ in unsafeCreateUptoN' bufSize $ \ptr -> do+ S{..} <- op (S ptr 0 0)+ let numBitsUsed = nextPtr `minusPtr` ptr * 8 + usedBits+ when (numBitsUsed > numBits) $ error $ unwords ["encoder: size mismatch, expected <=",show numBits,"actual=",show numBitsUsed,"bits"]+ return (nextPtr `minusPtr` ptr,numBitsUsed)++newtype Encoding =+ Encoding+ { run :: Prim+ }++instance Show Encoding where+ show _ = "Encoding"++instance Semigroup Encoding where+ {-# INLINE (<>) #-}+ (<>) = encodingAppend++instance Monoid Encoding where+ {-# INLINE mempty #-}+ mempty = Encoding return++#if !(MIN_VERSION_base(4,11,0))+ {-# INLINE mappend #-}+ mappend = encodingAppend+#endif++ {-# INLINE mconcat #-}+ mconcat = foldl' mappend mempty++{-# INLINE encodingAppend #-}+encodingAppend :: Encoding -> Encoding -> Encoding+encodingAppend (Encoding f) (Encoding g) = Encoding m+ where+ m s@(S !_ !_ !_) = do+ !s1 <- f s+ g s1++-- PROB: GHC 8.02 won't always apply the rules leading to poor execution times (e.g. with lists)+-- TODO: check with newest GHC versions+{-# RULES+"encodersSN" forall h t . encodersS (h : t) =+ h `mappend` encodersS t+"encodersS0" encodersS [] = mempty+ #-}++{-# NOINLINE encodersS #-}+encodersS :: [Encoding] -> Encoding+-- Without the explicit parameter the rules won't fire!+encodersS ws = foldl' mappend mempty ws++sizeListWith :: (Foldable t1, Num t2) => (t3 -> t2 -> t2) -> t1 t3 -> t2 -> t2+sizeListWith size l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l+{-# INLINE sizeListWith #-}++-- encodersS ws = error $ unwords ["encodersS CALLED",show ws]+{-# INLINE encodeListWith #-}+-- |Encode as a List+encodeListWith :: (t -> Encoding) -> [t] -> Encoding+encodeListWith enc = go+ where+ go [] = eFalse+ go (x:xs) = eTrue <> enc x <> go xs++-- {-# INLINE encodeList #-}+-- encodeList :: (Foldable t, Flat a) => t a -> Encoding+-- encodeList l = F.foldl' (\acc a -> acc <> eTrue <> encode a) mempty l <> eFalse+-- {-# INLINE encodeList2 #-}+-- encodeList2 :: (Foldable t, Flat a) => t a -> Encoding+-- encodeList2 l = foldr (\a acc -> eTrue <> encode a <> acc) mempty l <> eFalse+{-# INLINE encodeArrayWith #-}+-- |Encode as Array+encodeArrayWith :: (t -> Encoding) -> [t] -> Encoding+encodeArrayWith _ [] = eWord8 0+encodeArrayWith f ws = Encoding $ go ws+ where+ go l s = do+ -- write a placeholder for the number of elements in current block+ s' <- eWord8F 0 s+ (n, sn, l) <- gol l 0 s'+ -- update actual number of elements+ s'' <- updateWord8 n s sn+ if null l+ then eWord8F 0 s''+ else go l s''+ -- encode up to 255 elements and returns (numberOfWrittenElements,elementsLeftToWrite,currentState)+ gol [] !n !s = return (n, s, [])+ gol l@(x:xs) !n !s+ | n == 255 = return (255, s, l)+ | otherwise = run (f x) s >>= gol xs (n + 1)++-- Encoding primitives+{-# INLINE eChar #-}+{-# INLINE eUTF8 #-}+{-# INLINE eNatural #-}+{-# INLINE eFloat #-}+{-# INLINE eDouble #-}+{-# INLINE eInteger #-}+{-# INLINE eInt64 #-}+{-# INLINE eInt32 #-}+{-# INLINE eInt16 #-}+{-# INLINE eInt8 #-}+{-# INLINE eInt #-}+{-# INLINE eWord64 #-}+{-# INLINE eWord32 #-}+{-# INLINE eWord16 #-}+{-# INLINE eWord8 #-}+{-# INLINE eWord #-}+{-# INLINE eBits #-}+{-# INLINE eFiller #-}+{-# INLINE eBool #-}+{-# INLINE eTrue #-}+{-# INLINE eFalse #-}+eChar :: Char -> Encoding+eChar = Encoding . eCharF++#if! defined (ETA_VERSION)+{-# INLINE eUTF16 #-}+eUTF16 :: Text -> Encoding+eUTF16 = Encoding . eUTF16F+#endif++eUTF8 :: Text -> Encoding+eUTF8 = Encoding . eUTF8F++eBytes :: B.ByteString -> Encoding+eBytes = Encoding . eBytesF++eLazyBytes :: L.ByteString -> Encoding+eLazyBytes = Encoding . eLazyBytesF++eShortBytes :: ShortByteString -> Encoding+eShortBytes = Encoding . eShortBytesF++eNatural :: Natural -> Encoding+eNatural = Encoding . eNaturalF++eFloat :: Float -> Encoding+eFloat = Encoding . eFloatF++eDouble :: Double -> Encoding+eDouble = Encoding . eDoubleF++eInteger :: Integer -> Encoding+eInteger = Encoding . eIntegerF++eInt64 :: Int64 -> Encoding+eInt64 = Encoding . eInt64F++eInt32 :: Int32 -> Encoding+eInt32 = Encoding . eInt32F++eInt16 :: Int16 -> Encoding+eInt16 = Encoding . eInt16F++eInt8 :: Int8 -> Encoding+eInt8 = Encoding . eInt8F++eInt :: Int -> Encoding+eInt = Encoding . eIntF++eWord64 :: Word64 -> Encoding+eWord64 = Encoding . eWord64F++eWord32 :: Word32 -> Encoding+eWord32 = Encoding . eWord32F++eWord16 :: Word16 -> Encoding+eWord16 = Encoding . eWord16F++eWord8 :: Word8 -> Encoding+eWord8 = Encoding . eWord8F++eWord :: Word -> Encoding+eWord = Encoding . eWordF++eBits16 :: NumBits -> Word16 -> Encoding+eBits16 n f = Encoding $ eBits16F n f++eBits :: NumBits -> Word8 -> Encoding+eBits n f = Encoding $ eBitsF n f++eFiller :: Encoding+eFiller = Encoding eFillerF++eBool :: Bool -> Encoding+eBool = Encoding . eBoolF++eTrue :: Encoding+eTrue = Encoding eTrueF++eFalse :: Encoding+eFalse = Encoding eFalseF++-- Size Primitives+-- Variable size+{-# INLINE vsize #-}+vsize :: (t -> NumBits) -> t -> NumBits -> NumBits+vsize !f !t !n = f t + n++-- Constant size+{-# INLINE csize #-}+csize :: NumBits -> t -> NumBits -> NumBits+csize !n _ !s = n + s++sChar :: Size Char+sChar = vsize S.sChar++sInt64 :: Size Int64+sInt64 = vsize S.sInt64++sInt32 :: Size Int32+sInt32 = vsize S.sInt32++sInt16 :: Size Int16+sInt16 = vsize S.sInt16++sInt8 :: Size Int8+sInt8 = csize S.sInt8++sInt :: Size Int+sInt = vsize S.sInt++sWord64 :: Size Word64+sWord64 = vsize S.sWord64++sWord32 :: Size Word32+sWord32 = vsize S.sWord32++sWord16 :: Size Word16+sWord16 = vsize S.sWord16++sWord8 :: Size Word8+sWord8 = csize S.sWord8++sWord :: Size Word+sWord = vsize S.sWord++sFloat :: Size Float+sFloat = csize S.sFloat++sDouble :: Size Double+sDouble = csize S.sDouble++sBytes :: Size B.ByteString+sBytes = vsize S.sBytes++sLazyBytes :: Size L.ByteString+sLazyBytes = vsize S.sLazyBytes++sShortBytes :: Size ShortByteString+sShortBytes = vsize S.sShortBytes++sNatural :: Size Natural+sNatural = vsize S.sNatural++sInteger :: Size Integer+sInteger = vsize S.sInteger++sUTF8Max :: Size Text+sUTF8Max = vsize S.sUTF8Max++sUTF16 :: Size Text+sUTF16 = vsize S.sUTF16Max++sFillerMax :: Size a+sFillerMax = csize S.sFillerMax++sBool :: Size Bool+sBool = csize S.sBool
+ src/Flat/Encoder/Types.hs view
@@ -0,0 +1,25 @@+-- |Encoder Types+module Flat.Encoder.Types(+ Size,+ NumBits,+ Prim,+ S(..)+) where++import Flat.Types+import GHC.Ptr (Ptr (..))++-- |Add the maximum size in bits of the encoding of value a to a NumBits+type Size a = a -> NumBits -> NumBits++-- |Strict encoder state+data S =+ S+ { nextPtr :: {-# UNPACK #-} !(Ptr Word8)+ , currByte :: {-# UNPACK #-} !Word8+ , usedBits :: {-# UNPACK #-} !NumBits+ } deriving Show++-- |A basic encoder+type Prim = S -> IO S+
+ src/Flat/Endian.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+-- | Endian utilities+--+-- Exported for testing purposes, but not meant to be used outside this package.+module Flat.Endian+ (+ toBE32+ , toBE64+ , toBE16+ , isBigEndian+ -- , fix64+ ) where++#include "MachDeps.h"++import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32,+ byteSwap64)++-- #ifdef ghcjs_HOST_OS+-- import Data.Bits+-- #endif++-- $setup+-- >>> import Numeric (showHex)++isBigEndian :: Bool+isBigEndian =+#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION)+ True+#else+ False+#endif+++{- |+Convert a 64 bit value in cpu endianess to big endian++>>> toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0+True+-}+toBE64 :: Word64 -> Word64+#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION)+toBE64 = id+#else+toBE64 = byteSwap64+#endif++{- |+Convert a 32 bit value in cpu endianess to big endian++>>> toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0+True+-}+toBE32 :: Word32 -> Word32+#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION)+toBE32 = id+#else+toBE32 = byteSwap32+#endif++{- |+Convert a 16 bit value in cpu endianess to big endian++>>> toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0+True+-}+toBE16 :: Word16 -> Word16+#if defined(WORDS_BIGENDIAN) || defined(ETA_VERSION)+toBE16 = id+#else+toBE16 = byteSwap16+#endif
+ src/Flat/Filler.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++-- |Pre-value and post-value byte alignments+module Flat.Filler (+ Filler(..),+ fillerLength,+ PreAligned(..),+ preAligned,+ PostAligned(..),+ postAligned,+ preAlignedDecoder,+ postAlignedDecoder+ ) where++import Flat.Class ( Generic, Flat(..) )+import Flat.Encoder.Strict ( eFiller, sFillerMax )+import Flat.Decoder.Types ( Get )+import Control.DeepSeq ( NFData )+import Data.Typeable ( Typeable )++-- |A meaningless sequence of 0 bits terminated with a 1 bit (easier to implement than the reverse)+-- +-- Used to align encoded values at byte/word boundaries.+data Filler = FillerBit !Filler+ | FillerEnd+ deriving (Show, Eq, Ord, Typeable, Generic, NFData)++-- |Use a special encoding for the filler+instance Flat Filler where+ encode _ = eFiller+ size = sFillerMax+ -- use generated decode++-- |A Post aligned value, a value followed by a filler+-- +-- Useful to complete the encoding of a top-level value+data PostAligned a = PostAligned { postValue :: a, postFiller :: Filler }+#ifdef ETA_VERSION + deriving (Show, Eq, Ord, Typeable, Generic, NFData)++instance Flat a => Flat (PostAligned a) where+ encode (PostAligned val fill) = trampolineEncoding (encode val) <> encode fill++#else+ deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)+#endif+-- deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)+++-- |A Pre aligned value, a value preceded by a filler+-- +-- Useful to prealign ByteArrays, Texts and any structure that can be encoded more efficiently when byte aligned. +data PreAligned a = PreAligned { preFiller :: Filler, preValue :: a }+ deriving (Show, Eq, Ord, Typeable, Generic, NFData, Flat)++-- |Length of a filler in bits+fillerLength :: Num a => Filler -> a+fillerLength FillerEnd = 1+fillerLength (FillerBit f) = 1 + fillerLength f++-- |Post align a value+postAligned :: a -> PostAligned a+postAligned a = PostAligned a FillerEnd++-- |Pre align a value+preAligned :: a -> PreAligned a+preAligned = PreAligned FillerEnd++-- |Decode a value assuming that is PostAligned+postAlignedDecoder :: Get b -> Get b+postAlignedDecoder dec = do+ v <- dec+ _::Filler <- decode+ return v++-- |Decode a value assuming that is PreAligned+-- +-- @since 0.5+preAlignedDecoder :: Get b -> Get b+preAlignedDecoder dec = do+ _::Filler <- decode+ dec
+ src/Flat/Instances.hs view
@@ -0,0 +1,15 @@++-- |Flat Instances for common data types from the packages on which `flat` has a dependency.+module Flat.Instances+ ( module X+ )+where++import Flat.Instances.Array ( )+import Flat.Instances.Base ( )+import Flat.Instances.ByteString ( )+import Flat.Instances.Containers as X+import Flat.Instances.DList ( )+import Flat.Instances.Mono as X+import Flat.Instances.Text as X+import Flat.Instances.Unordered ( )
+ src/Flat/Instances/Array.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Flat instances for the `array` package+module Flat.Instances.Array+ ()+where++import qualified Data.Array as A+import qualified Data.Array.Unboxed as U+import Data.Array.IArray+import Flat.Class+import Flat.Decoder+import Flat.Encoder+import Flat.Instances.Base ( )+-- import Flat.Instances.Util+import Flat.Instances.Mono++-- $setup+-- >>> :set -XFlexibleContexts+-- >>> import Flat.Instances.Test+-- >>> import Flat.Instances.Mono+-- >>> import qualified Data.Array as A+-- >>> import qualified Data.Array.Unboxed as U+-- >>> import Data.Array.IArray+-- >>> import Data.Word++{-|+Array is encoded as (lowBound,highBound,AsArray (elems array)):++>>> let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr +True++As it's easy to see:++>>> tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)]+(True,80,[1,4,2,5,4,11,22,33,44,0])++>>> tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")]+(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0])++Arrays and Unboxed Arrays are encoded in the same way:++>>> let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems)+True+-}+instance (Flat i, Flat e, Ix i) => Flat (A.Array i e) where+ size = sizeIArray++ encode = encodeIArray++ decode = decodeIArray++instance (Flat i, Flat e, Ix i, IArray U.UArray e) => Flat (U.UArray i e) where+ size = sizeIArray++ encode = encodeIArray++ decode = decodeIArray++sizeIArray :: (IArray a e, Ix i, Flat e, Flat i) => a i e -> NumBits -> NumBits+sizeIArray arr = (sizeSequence . elems $ arr) . size (bounds arr)++encodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => a i e -> Encoding+encodeIArray arr = encode (bounds arr) <> encodeSequence (elems arr)++decodeIArray :: (Ix i, IArray a e, Flat i, Flat e) => Get (a i e)+decodeIArray = listArray <$> decode <*> decodeSequence++{-# INLINE sizeIArray #-}+{-# INLINE encodeIArray #-}+{-# INLINE decodeIArray #-}
+ src/Flat/Instances/Base.hs view
@@ -0,0 +1,713 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Flat instances for the base library+module Flat.Instances.Base () where++import Control.Monad (liftM2)+import Data.Bool+import Data.Char+import Data.Complex (Complex (..))+import Data.Fixed+-- #if MIN_VERSION_base(4,9,0)+import qualified Data.List.NonEmpty as B+-- #endif++#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Monoid (mempty)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Semigroup+#endif++import qualified Data.Monoid as Monoid+import Data.Ratio+import Flat.Instances.Util+import Prelude hiding (mempty)++-- #if !MIN_VERSION_base(4,9,0)+-- import Data.Monoid ((<>))+-- #endif++#if MIN_VERSION_base(4,9,0)+import Data.Functor.Identity (Identity (..))+#endif++-- #if !MIN_VERSION_base(4,9,0)+-- deriving instance Generic (Complex a)+-- #endif++{- ORMOLU_DISABLE -}+-- $setup+-- >>> :set -XNegativeLiterals -XTypeApplications+-- >>> import Flat.Instances.Test+-- >>> import Data.Fixed+-- >>> import Data.Int+-- >>> import Data.Complex(Complex(..))+-- >>> import Numeric.Natural+-- >>> import Data.Word+-- >>> import Data.Ratio+-- >>> import Flat.Run+-- >>> import Data.Monoid+-- >>> import qualified Data.List.NonEmpty as B+-- >>> let test = tstBits+-- >>> let y = 33+{- ORMOLU_ENABLE -}++-- >>> y++-- | @since 0.4.4+#if MIN_VERSION_base(4,8,0)+instance Flat Monoid.All where+ encode (Monoid.All a) = encode a+ size (Monoid.All a) = size a+ decode = Monoid.All <$> decode++{- |++>>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w+True++>>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w+True++@since 0.4.4+-}+instance Flat (f a) => Flat (Monoid.Alt f a) where+ encode (Monoid.Alt a) = encode a+ size (Monoid.Alt a) = size a+ decode = Monoid.Alt <$> decode+#endif++#if MIN_VERSION_base(4,9,0)+-- | @since 0.4.4+instance Flat a => Flat (Identity a) where+ encode (Identity a) = encode a+ size (Identity a) = size a+ decode = Identity <$> decode+#endif++-- | @since 0.4.4+instance Flat a => Flat (Monoid.Dual a) where+ encode (Monoid.Dual a) = encode a+ size (Monoid.Dual a) = size a+ decode = Monoid.Dual <$> decode++-- | @since 0.4.4+instance Flat Monoid.Any where+ encode (Monoid.Any a) = encode a+ size (Monoid.Any a) = size a+ decode = Monoid.Any <$> decode++-- | @since 0.4.4+instance Flat a => Flat (Monoid.Sum a) where+ encode (Monoid.Sum a) = encode a+ size (Monoid.Sum a) = size a+ decode = Monoid.Sum <$> decode++-- | @since 0.4.4+instance Flat a => Flat (Monoid.Product a) where+ encode (Monoid.Product a) = encode a+ size (Monoid.Product a) = size a+ decode = Monoid.Product <$> decode++#if MIN_VERSION_base(4,9,0)+-- | @since 0.4.4+instance Flat a => Flat (Semigroup.Min a) where+ encode (Semigroup.Min a) = encode a+ size (Semigroup.Min a) = size a+ decode = Semigroup.Min <$> decode++-- | @since 0.4.4+instance Flat a => Flat (Semigroup.Max a) where+ encode (Semigroup.Max a) = encode a+ size (Semigroup.Max a) = size a+ decode = Semigroup.Max <$> decode++-- | @since 0.4.4+instance Flat a => Flat (Semigroup.First a) where+ encode (Semigroup.First a) = encode a+ size (Semigroup.First a) = size a+ decode = Semigroup.First <$> decode++-- | @since 0.4.4+instance Flat a => Flat (Semigroup.Last a) where+ encode (Semigroup.Last a) = encode a+ size (Semigroup.Last a) = size a+ decode = Semigroup.Last <$> decode+#endif++{- |+`()`, as all data types with a single constructor, has a zero-length encoding.++>>> test ()+(True,0,"")+-}+instance Flat () where+ encode _ = mempty++ size _ = id++ decode = pure ()++{- |+One bit is plenty for a Bool.++>>> test False+(True,1,"0")++>>> test True+(True,1,"1")+-}+instance Flat Bool where+ encode = eBool++ size = sBool++ decode = dBool++{- |+Char's are mapped to Word32 and then encoded.++For ascii characters, the encoding is standard ascii.++>>> test 'a'+(True,8,"01100001")++For unicode characters, the encoding is non standard.++>>> test 'È'+(True,16,"11001000 00000001")++>>> test '不'+(True,24,"10001101 10011100 00000001")++#ifndef ETA+>>> test "\x1F600"+(True,26,"11000000 01110110 00000011 10")+#endif+-}+instance Flat Char where+ size = sChar++ encode = eChar++ decode = dChar++{- |+>>> test (Nothing::Maybe Bool)+(True,1,"0")++>>> test (Just False::Maybe Bool)+(True,2,"10")+-}+instance Flat a => Flat (Maybe a)++{- |+>>> test (Left False::Either Bool ())+(True,2,"00")++>>> test (Right ()::Either Bool ())+(True,1,"1")+-}+instance (Flat a, Flat b) => Flat (Either a b)++{- |+>>> test (MkFixed 123 :: Fixed E0)+(True,16,"11110110 00000001")++>>> test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2)+True+-}+instance Flat (Fixed a) where+ encode (MkFixed n) = encode n++ size (MkFixed n) = size n++ decode = MkFixed <$> decode++{- |+Word8 always take 8 bits.++>>> test (0::Word8)+(True,8,"00000000")++>>> test (255::Word8)+(True,8,"11111111")+-}+instance Flat Word8 where+ encode = eWord8++ decode = dWord8++ size = sWord8++{- |+Natural, Word, Word16, Word32 and Word64 are encoded as a non empty list of 7 bits chunks (least significant chunk first and most significant bit first in every chunk).++Words are always encoded in a whole number of bytes, as every chunk is 8 bits long (1 bit for the List constructor, plus 7 bits for the value).++The actual definition is:++@+Word64 ≡ Word64 Word++Word32 ≡ Word32 Word++Word16 ≡ Word16 Word++Word ≡ Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))++LeastSignificantFirst a ≡ LeastSignificantFirst a++NonEmptyList a ≡ Elem a+ | Cons a (NonEmptyList a)++MostSignificantFirst a ≡ MostSignificantFirst a++Word7 ≡ V0+ | V1+ | V2+ ...+ | V127+@++Values between as 0 and 127 fit in a single byte.++127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111++>>> test (127::Word)+(True,8,"01111111")++254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001):++>>> test (254::Word)+(True,16,"11111110 00000001")++Another example, 32768 (Ob1000000000000000 = 0000010 0000000 0000000):++>>> test (32768::Word32)+(True,24,"10000000 10000000 00000010")++As this is a variable length encoding, values are encoded in the same way, whatever their type:++>>> all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)]+True+++Word/Int decoders return an error if the encoded value is outside their valid range:++>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound)+Right 65535++>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound + 1)+Left (BadEncoding ...++>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound)+Right 4294967295++>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound + 1)+Left (BadEncoding ...++>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound)+Right 18446744073709551615++>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound + 1)+Left (BadEncoding ...++++>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound)+Right 32767++>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound + 1)+Left (BadEncoding ...++>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound)+Right 2147483647++>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound + 1)+Left (BadEncoding ...++>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound)+Right 9223372036854775807++>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound + 1)+Left (BadEncoding ...+++>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound)+Right (-32768)++>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound - 1)+Left (BadEncoding ...++>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound)+Right (-2147483648)++>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound - 1)+Left (BadEncoding ...++>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound)+Right (-9223372036854775808)++>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound - 1)+Left (BadEncoding ...+-}+instance Flat Word where+ size = sWord++ encode = eWord++ decode = dWord++{- |+Naturals are encoded just as the fixed size Words.++>>> test (0::Natural)+(True,8,"00000000")++>>> test (2^120::Natural)+(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010")+-}+instance Flat Natural where+ size = sNatural++ encode = eNatural++ decode = dNatural++instance Flat Word16 where+ encode = eWord16++ decode = dWord16++ size = sWord16++instance Flat Word32 where+ encode = eWord32++ decode = dWord32++ size = sWord32++instance Flat Word64 where+ encode = eWord64++ decode = dWord64++ size = sWord64++{- |+Integer, Int, Int16, Int32 and Int64 are defined as the <https://developers.google.com/protocol-buffers/docs/encoding#signed-integers ZigZag> encoded version of the equivalent unsigned Word:++@+Int ≡ Int (ZigZag Word)++Int64 ≡ Int64 (ZigZag Word64)++Int32 ≡ Int32 (ZigZag Word32)++Int16 ≡ Int16 (ZigZag Word16)++Int8 ≡ Int8 (ZigZag Word8)++ZigZag a ≡ ZigZag a+@++ZigZag encoding alternates between positive and negative numbers, so that numbers whose absolute value is small can be encoded efficiently:++>>> test (0::Int)+(True,8,"00000000")++>>> test (-1::Int)+(True,8,"00000001")++>>> test (1::Int)+(True,8,"00000010")++>>> test (-2::Int)+(True,8,"00000011")++>>> test (2::Int)+(True,8,"00000100")+-}+instance Flat Int where+ size = sInt++ encode = eInt++ decode = dInt++{- |+Integers are encoded just as the fixed size Ints.++>>> test (0::Integer)+(True,8,"00000000")++>>> test (-1::Integer)+(True,8,"00000001")++>>> test (1::Integer)+(True,8,"00000010")++>>> test (-(2^4)::Integer)+(True,8,"00011111")++>>> test (2^4::Integer)+(True,8,"00100000")++>>> test (-(2^120)::Integer)+(True,144,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011")++>>> test (2^120::Integer)+(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100")+-}+instance Flat Integer where+ size = sInteger++ encode = eInteger++ decode = dInteger++{- |+>>> test (0::Int8)+(True,8,"00000000")++>>> test (127::Int8)+(True,8,"11111110")++>>> test (-128::Int8)+(True,8,"11111111")+-}+instance Flat Int8 where+ encode = eInt8++ decode = dInt8++ size = sInt8++{- |+>>> test (0::Int16)+(True,8,"00000000")++>>> test (1::Int16)+(True,8,"00000010")++>>> test (-1::Int16)+(True,8,"00000001")++>>> test (minBound::Int16)+(True,24,"11111111 11111111 00000011")++equivalent to 0b1111111111111111++>>> test (maxBound::Int16)+(True,24,"11111110 11111111 00000011")++equivalent to 0b1111111111111110+-}+instance Flat Int16 where+ size = sInt16++ encode = eInt16++ decode = dInt16++{- |+>>> test (0::Int32)+(True,8,"00000000")++>>> test (minBound::Int32)+(True,40,"11111111 11111111 11111111 11111111 00001111")++>>> test (maxBound::Int32)+(True,40,"11111110 11111111 11111111 11111111 00001111")+-}+instance Flat Int32 where+ size = sInt32++ encode = eInt32++ decode = dInt32++{- |+>>> test (0::Int64)+(True,8,"00000000")++>>> test (minBound::Int64)+(True,80,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")++>>> test (maxBound::Int64)+(True,80,"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")+-}+instance Flat Int64 where+ size = sInt64++ encode = eInt64++ decode = dInt64++{- |+Floats are encoded as standard IEEE binary32 values:++@+IEEE_754_binary32 ≡ IEEE_754_binary32 {sign :: Sign,+ exponent :: MostSignificantFirst Bits8,+ fraction :: MostSignificantFirst Bits23}+@++>>> test (0::Float)+(True,32,"00000000 00000000 00000000 00000000")++>>> test (1.4012984643E-45::Float)+(True,32,"00000000 00000000 00000000 00000001")++>>> test (1.1754942107E-38::Float)+(True,32,"00000000 01111111 11111111 11111111")+-}+instance Flat Float where+ size = sFloat++ encode = eFloat++ decode = dFloat++{- |+Doubles are encoded as standard IEEE binary64 values:++@+IEEE_754_binary64 ≡ IEEE_754_binary64 {sign :: Sign,+ exponent :: MostSignificantFirst Bits11,+ fraction :: MostSignificantFirst Bits52}+@+-}+instance Flat Double where+ size = sDouble++ encode = eDouble++ decode = dDouble++{- |+>>> test (4 :+ 2 :: Complex Word8)+(True,16,"00000100 00000010")+-}+instance Flat a => Flat (Complex a)++{- |+Ratios are encoded as tuples of (numerator,denominator)++>>> test (3%4::Ratio Word8)+(True,16,"00000011 00000100")+-}+instance (Integral a, Flat a) => Flat (Ratio a) where+ size a = size (numerator a, denominator a)++ encode a = encode (numerator a, denominator a)++ -- decode = uncurry (%) <$> decode+ decode = liftM2 (%) decode decode++{- |+>>> test ([]::[Bool])+(True,1,"0")++>>> test [False,False]+(True,5,"10100")++This instance and other similar ones are declared as @OVERLAPPABLE@, because for better encoding/decoding+performance it can be useful to declare instances of concrete types, such as @[Char]@ (not provided out of the box).+-}+instance {-# OVERLAPPABLE #-} Flat a => Flat [a]++{-+>>> import Weigh+>>> flat [1..10::Int]+-}+++-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901)+-- where+--size [] n = n+1+--size (h:t) n = trampoline size t (trampoline size h (n+1))+-- size = sizeListWith size -- foldl' (\n e -> ) n+-- encode = error "BAD"+-- encode = trampoline . encodeListWith encode+-- decode = decodeListWith decode+-- sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l+-- #ifdef ETA_VERSION+-- import Data.Function(trampoline)+-- import GHC.IO(trampolineIO)+-- #else+-- trampoline = id+-- trampolineIO = id+-- #endif++-- #if MIN_VERSION_base(4,9,0)++{- |+>>> test (B.fromList [True])+(True,2,"10")++>>> test (B.fromList [False,False])+(True,4,"0100")+-}+instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a)++-- #endif++{- |+Tuples are supported up to 7 elements.++>>> test (False,())+(True,1,"0")++>>> test ((),())+(True,0,"")++"7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal)++>>> test (False,True,True,True,False,True,True)+(True,7,"0111011")++tst (1::Int,"2","3","4","5","6","7","8")+...error+-}++-- Not sure if these should be OVERLAPPABLE+instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b)++instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c)++instance+ {-# OVERLAPPABLE #-}+ (Flat a, Flat b, Flat c, Flat d) =>+ Flat (a, b, c, d)++instance+ {-# OVERLAPPABLE #-}+ (Flat a, Flat b, Flat c, Flat d, Flat e) =>+ Flat (a, b, c, d, e)++instance+ {-# OVERLAPPABLE #-}+ (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) =>+ Flat (a, b, c, d, e, f)++instance+ {-# OVERLAPPABLE #-}+ ( Flat a+ , Flat b+ , Flat c+ , Flat d+ , Flat e+ , Flat f+ , Flat g+ ) =>+ Flat (a, b, c, d, e, f, g)
+ src/Flat/Instances/ByteString.hs view
@@ -0,0 +1,87 @@+-- | Flat instances for the bytestring library+{-# LANGUAGE NoMonomorphismRestriction #-}+module Flat.Instances.ByteString+ ()+where++import Flat.Class+import Flat.Decoder+import Flat.Encoder+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS++-- $setup+-- >>> import Flat.Instances.Test+-- >>> import Flat.Instances.Base+-- >>> import qualified Data.ByteString as B+-- >>> import qualified Data.ByteString.Lazy as L+-- >>> import qualified Data.ByteString.Short as SBS++{-|+ByteString, ByteString.Lazy and ByteString.Short are all encoded as Prealigned Arrays:++@+PreAligned a ≡ PreAligned {preFiller :: Filler, preValue :: a}++Filler ≡ FillerBit Filler+ | FillerEnd++Array v = A0+ | A1 v (Array v)+ | A2 v v (Array v)+ ...+ | A255 ... (Array v)+@++That's to say as a byte-aligned sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block.++>>> tst (B.pack [11,22,33])+(True,48,[1,3,11,22,33,0])++where:++1= PreAlignment (takes a byte if we are already on a byte boundary)++3= Number of bytes in ByteString++11,22,33= Bytes++0= End of Array++>>> tst (B.pack [])+(True,16,[1,0])++Pre-alignment ensures that a ByteString always starts at a byte boundary:++>>> tst ((False,True,False,B.pack [11,22,33]))+(True,51,[65,3,11,22,33,0])++All ByteStrings are encoded in the same way:++>>> all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])]+True+-}+instance Flat B.ByteString where+ encode = eBytes+ size = sBytes+ decode = dByteString++{- |+>>> tst ((False,True,False,L.pack [11,22,33]))+(True,51,[65,3,11,22,33,0])+-}+instance Flat L.ByteString where+ encode = eLazyBytes+ size = sLazyBytes+ decode = dLazyByteString++{- |+>>> tst ((False,True,False,SBS.pack [11,22,33]))+(True,51,[65,3,11,22,33,0])+-}+instance Flat SBS.ShortByteString where+ encode = eShortBytes+ size = sShortBytes+ decode = dShortByteString+
+ src/Flat/Instances/Containers.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving ,DeriveGeneric #-}++{-# LANGUAGE CPP #-}+-- |Instances for the containers library+module Flat.Instances.Containers (sizeMap+ , encodeMap+ , decodeMap+) where++import Flat.Instances.Util+import Data.Map +import Flat.Instances.Base()+import Flat.Instances.Mono+import Data.Tree +import Data.Set+import Data.IntMap +import Data.Sequence++-- $setup+-- >>> import Flat.Instances.Test+-- >>> import Data.Set+-- >>> import Data.Sequence+-- >>> import Data.IntMap+-- >>> import Data.Map +-- >>> import Data.Tree +-- >>> import Flat.Instances.Mono++{-|+Maps are defined as a list of (Key,Value) tuples:++@+Map = List (Key,Value)++List a = Nil | Cons a (List a)+@+-}++{-|+>>> tst (Data.IntMap.empty :: IntMap ())+(True,1,[0])++>>> asList Data.IntMap.fromList [(1,"a"),(2,"b")]+True+-}+instance Flat a => Flat (IntMap a) where+ size = sizeMap+ encode = encodeMap+ decode = decodeMap++{-|+Maps are encoded as lists:++>>> tst (Data.Map.empty :: Map () ())+(True,1,[0])++>>> asList Data.Map.fromList [("a","aa"),("b","bb")]+True++Key/Values are encoded in order:++>>> let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l)+True++IntMap and Map are encoded in the same way:++>>> let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l)+True+-}+instance (Flat a, Flat b, Ord a) => Flat (Map a b) where+ size = sizeMap+ encode = encodeMap+ decode = decodeMap++{-|+Data.Sequence.Seq is encoded as a list.++>>> asList Data.Sequence.fromList [3::Word8,4,7]+True++In flat <0.4, it was encoded as an Array.++If you want to restore the previous behaviour, use AsArray:++>>> tst $ AsArray (Data.Sequence.fromList [11::Word8,22,33])+(True,40,[3,11,22,33,0])++>>> tst $ Data.Sequence.fromList [11::Word8,22,33]+(True,28,[133,197,164,32])+-}+instance Flat a => Flat (Seq a) where+ size = sizeList -- . toList+ encode = encodeList -- . Data.Sequence.toList+ decode = Data.Sequence.fromList <$> decodeList++{-|+Data.Set is encoded as a list++>>> asList Data.Set.fromList [3::Word8,4,7]+True+-}+instance (Flat a,Ord a) => Flat (Set a) where+ size = sizeSet+ encode = encodeSet+ decode = decodeSet++{-|+>>> tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []])+(True,39,[1,129,64,200,32])+-}+#if ! MIN_VERSION_containers(0,5,8)+deriving instance Generic (Tree a)+#endif++instance (Flat a) => Flat (Tree a)
+ src/Flat/Instances/DList.hs view
@@ -0,0 +1,27 @@+module Flat.Instances.DList+ ()+where++import Data.DList (DList, fromList, toList)+import Flat.Class (Flat (..))+import Flat.Instances.Mono (decodeList, encodeList, sizeList)++-- $setup+-- >>> import Flat.Instances.Test+-- >>> import Flat.Instances.Base()+-- >>> import Flat.Run+-- >>> import Data.DList+-- >>> let test = tstBits++{-|+>>> test (Data.DList.fromList [7::Word,7])+(True,19,"10000011 11000001 110")++>>> let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l+True+-}++instance Flat a => Flat (DList a) where+ size = sizeList . toList+ encode = encodeList . toList+ decode = fromList <$> decodeList
+ src/Flat/Instances/Extra.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+module Flat.Instances.Extra where++import Flat.Instances.Base ()+import Flat.Class ( Flat )++-- $setup+-- >>> import Flat.Instances.Test++{- |+For better encoding/decoding performance, it is useful to declare instances of concrete list types, such as [Char].++>>> tstBits ""+(True,1,"0")++>>> tstBits "aaa"+(True,28,"10110000 11011000 01101100 0010")+-}+instance {-# OVERLAPPING #-} Flat [Char]+
+ src/Flat/Instances/Mono.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+module Flat.Instances.Mono+ ( sizeSequence+ , encodeSequence+ , decodeSequence+ , sizeList+ , encodeList+ , decodeList+ , sizeSet+ , encodeSet+ , decodeSet+ , sizeMap+ , encodeMap+ , decodeMap+ , AsArray(..)+ , AsList(..)+ , AsSet(..)+ , AsMap(..)+ )+where++import Data.Containers+import qualified Data.Foldable as F+import Data.MonoTraversable (Element, MonoFoldable, ofoldl', otoList)+import Data.Sequences (IsSequence)+import qualified Data.Sequences as S+import Flat.Instances.Util++{- $setup+>>> import Flat.Instances.Base()+>>> import Flat.Instances.Test+>>> import Data.Word+>>> import qualified Data.Set+>>> import qualified Data.Map+-}++{-|+Sequences are defined as Arrays:++Array v = A0+ | A1 v (Array v)+ | A2 v v (Array v)+ ...+ | A255 ... (Array v)++In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block.++Lists are defined as:++List a ≡ Nil+ | Cons a (List a)++In practice, this means that the list elements will be prefixed with a 1 bit and followed by a final 0 bit.++The AsList/AsArray wrappers can be used to serialise sequences as Lists or Arrays.++Let's see some examples.++>>> flatBits $ AsList [True,True,True]+"1111110"++So we have Cons True (11) repeated three times, followed by a final Nil (0).++The list encoding is the default one for lists so AsList is in this case unnecessary:++>>> flatBits $ [True,True,True]+"1111110"++We can force a list to be encoded as an Array with AsArray:++>>> flatBits $ AsArray [True,True,True]+"00000011 11100000 000"++We have the initial block with a count of 3 (3 == 00000011) followed by the elements True True True (111) and then the final block of 0 elements ("00000 000").++>>> flatBits $ [AsArray [True,True,True]]+"10000001 11110000 00000"++>>> flatBits $ (True,True,True,AsArray $ replicate 7 True)+"11100000 11111111 11000000 00"++>>> flatBits $ AsArray ([]::[()])+"00000000"++>>> flatBits $ AsList ([]::[()])+"0"++>>> tst (AsList [11::Word8,22,33])+(True,28,[133,197,164,32])++>>> tst (AsSet (Data.Set.fromList [11::Word8,22,33]))+(True,28,[133,197,164,32])++>>> tst [AsArray [1..3], AsArray [4..8]]+(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0])++>>> tst $ [AsArray [(1::Word8)..3], AsArray [4..8]]+(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0])++>>> tst $ [AsArray [(1::Int)..3]]+(True,42,[129,129,2,3,0,0])+-}+newtype AsArray a =+ AsArray+ { unArray :: a+ } deriving (Show,Eq,Ord)++instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where+ size (AsArray a) = sizeSequence a+ encode (AsArray a) = encodeSequence a+ decode = AsArray <$> decodeSequence++{- |+Calculate size of an instance of IsSequence as the sum:++* of the size of all the elements++* plus the size of the array constructors (1 byte every 255 elements plus one final byte)+-}+sizeSequence+ :: (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits+sizeSequence s acc =+ let (sz, len) =+ ofoldl' (\(acc, l) e -> (size e acc, l + 1)) (acc, 0 :: NumBits) s+ in sz + arrayBits len+{-# INLINE sizeSequence #-}++-- TODO: check which one is faster+-- sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s)++-- |Encode an instance of IsSequence, as an array+encodeSequence :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding+encodeSequence = encodeArray . otoList+{-# INLINE encodeSequence #-}++-- |Decode an instance of IsSequence, as an array+decodeSequence :: (Flat (Element b), IsSequence b) => Get b+decodeSequence = S.fromList <$> decodeArrayWith decode+{-# INLINE decodeSequence #-}++newtype AsList a =+ AsList+ { unList :: a+ } deriving (Show,Eq,Ord)++instance (IsSequence l, Flat (Element l)) => Flat (AsList l) where+ -- size = sizeList . S.unpack . unList+ -- encode = encodeList . S.unpack . unList+ -- decode = AsList . S.fromList <$> decodeListotoList++ size = sizeList . unList+ encode = encodeList . unList+ decode = AsList <$> decodeList++{-# INLINE sizeList #-}+sizeList+ :: (MonoFoldable mono, Flat (Element mono)) => mono -> NumBits -> NumBits+sizeList l sz = ofoldl' (\s e -> size e (s + 1)) (sz + 1) l++{-# INLINE encodeList #-}+encodeList :: (Flat (Element mono), MonoFoldable mono) => mono -> Encoding+encodeList = encodeListWith encode . otoList++{-# INLINE decodeList #-}+decodeList :: (IsSequence b, Flat (Element b)) => Get b+decodeList = S.fromList <$> decodeListWith decode++{-|+Sets are saved as lists of values.++>>> tstBits $ AsSet (Data.Set.fromList ([False,True,False]::[Bool]))+(True,5,"10110")+-}+newtype AsSet a =+ AsSet+ { unSet :: a+ } deriving (Show,Eq,Ord)++instance (IsSet set, Flat (Element set)) => Flat (AsSet set) where+ size = sizeSet . unSet+ encode = encodeSet . unSet+ decode = AsSet <$> decodeSet++sizeSet :: (IsSet set, Flat (Element set)) => Size set+sizeSet l acc = ofoldl' (\acc e -> size e (acc + 1)) (acc + 1) l+{-# INLINE sizeSet #-}++encodeSet :: (IsSet set, Flat (Element set)) => set -> Encoding+encodeSet = encodeList . setToList+{-# INLINE encodeSet #-}++decodeSet :: (IsSet set, Flat (Element set)) => Get set+decodeSet = setFromList <$> decodeList+{-# INLINE decodeSet #-}++{-|+Maps are saved as lists of (key,value) tuples.++>>> tst (AsMap (Data.Map.fromList ([]::[(Word8,())])))+(True,1,[0])++>>> tst (AsMap (Data.Map.fromList [(3::Word,9::Word)]))+(True,18,[129,132,128])+-}+newtype AsMap a =+ AsMap+ { unMap :: a+ } deriving (Show,Eq,Ord)++instance (IsMap map, Flat (ContainerKey map), Flat (MapValue map)) => Flat (AsMap map) where+ size = sizeMap . unMap+ encode = encodeMap . unMap+ decode = AsMap <$> decodeMap++{-# INLINE sizeMap #-}+sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r+sizeMap m acc =+ F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1)+ . mapToList+ $ m+-- sizeMap l sz = ofoldl' (\s (k, v) -> size k (size v (s + 1))) (sz + 1) l++{-# INLINE encodeMap #-}+-- |Encode an instance of IsMap, as a list of (Key,Value) tuples+encodeMap+ :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map)+ => map+ -> Encoding+encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList++{-# INLINE decodeMap #-}+-- |Decode an instance of IsMap, as a list of (Key,Value) tuples+decodeMap+ :: (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map+decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode)+
+ src/Flat/Instances/Test.hs view
@@ -0,0 +1,48 @@+-- | doctest utilities+module Flat.Instances.Test (+ tst,+ tstBits,+ asList,+ flatBits,+ allBits,+ encBits,+ prettyShow,+ module Data.Word,+) where++import Control.Monad ((>=>))+import Data.Word+import Flat.Bits (Bits, asBytes, bits,+ paddedBits, takeBits,toBools)+import Flat.Class (Flat (..))+import Flat.Encoder.Prim (eFillerF)+import Flat.Encoder.Strict (Encoding (Encoding),+ numEncodedBits, strictEncoder)+import Flat.Run (flat, unflat)+import Flat.Types (NumBits)+import Text.PrettyPrint.HughesPJClass (prettyShow)++-- | Returns: result of flat/unflat test, encoding size in bits, byte encoding+tst :: (Eq a, Flat a) => a -> (Bool, NumBits, [Word8])+tst v = (unflat (flat v) == Right v && size v 0 >= length (toBools (bits v)), size v 0, showBytes v)++-- | Returns: result of flat/unflat test, encoding size in bits, bits encoding+tstBits :: (Eq a, Flat a) => a -> (Bool, NumBits, String)+tstBits v = (unflat (flat v) == Right v, Flat.Class.size v 0, flatBits v)++-- | Test that container is serialised as a List+asList :: (Eq a1, Eq a2, Flat a1, Flat a2) => (a2 -> a1) -> a2 -> Bool+asList f l = tst (f l) == tst l++flatBits :: Flat a => a -> String+flatBits = prettyShow . bits++allBits :: Flat a => a -> String+allBits = prettyShow . paddedBits++-- |@since 0.5+encBits :: NumBits -> Encoding -> Bits+encBits maxNumBits e@(Encoding enc) = takeBits (numEncodedBits maxNumBits e) (strictEncoder maxNumBits (Encoding $ enc >=> eFillerF))++showBytes :: Flat a => a -> [Word8]+showBytes = asBytes . bits
+ src/Flat/Instances/Text.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}++-- | Flat instances for the text library+module Flat.Instances.Text(+ UTF8Text(..)+#if! defined (ETA_VERSION) && ! defined (ETA)+ ,UTF16Text(..)+#endif+) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Flat.Instances.Util++-- $setup+-- >>> import Flat.Instances.Base()+-- >>> import Flat.Instances.Test+-- >>> import qualified Data.Text as T+-- >>> import qualified Data.Text.Lazy as TL+-- >>> import Data.Word+-- >>> tt t = let (ts,_,bs) = tst t in (ts,bs) ++{- |+Text (and Data.Text.Lazy) is encoded as a byte aligned array of bytes corresponding to its UTF8 encoding.++>>> tt $ T.pack ""+(True,[1,0])++>>> tt $ T.pack "aaa"+(True,[1,3,97,97,97,0])++>>> tt $ T.pack "¢¢¢"+(True,[1,6,194,162,194,162,194,162,0])++>>> tt $ T.pack "日日日"+(True,[1,9,230,151,165,230,151,165,230,151,165,0])++#ifndef ETA+>>> tt $ T.pack "𐍈𐍈𐍈"+(True,[1,12,240,144,141,136,240,144,141,136,240,144,141,136,0])+#endif++Strict and Lazy Text have the same encoding:++>>> tst (T.pack "abc") == tst (TL.pack "abc")+True+-}+instance Flat T.Text where+ size = sUTF8Max+ encode = eUTF8+ decode = dUTF8++instance Flat TL.Text where+ size = sUTF8Max . TL.toStrict+ encode = eUTF8 . TL.toStrict+ decode = TL.fromStrict <$> dUTF8++{-|+The desired text encoding can be explicitly specified using the wrappers UTF8Text and UTF16Text.++The default encoding is UTF8:++>>> tst (UTF8Text $ T.pack "日日日") == tst (T.pack "日日日")+True+-}+-- |A wrapper to encode/decode Text as UTF8+newtype UTF8Text = UTF8Text {unUTF8::T.Text} deriving (Eq,Ord,Show)++instance Flat UTF8Text where+ size (UTF8Text t) = sUTF8Max t+ encode (UTF8Text t) = eUTF8 t+ decode = UTF8Text <$> dUTF8++#if ! defined (ETA_VERSION) && ! defined (ETA)+{-|+>>> tt (UTF16Text $ T.pack "aaa")+(True,[1,6,97,0,97,0,97,0,0])++>>> tt (UTF16Text $ T.pack "𐍈𐍈𐍈")+(True,[1,12,0,216,72,223,0,216,72,223,0,216,72,223,0])+-}++-- |A wrapper to encode/decode Text as UTF16+newtype UTF16Text = UTF16Text {unUTF16::T.Text} deriving (Eq,Ord,Show)++instance Flat UTF16Text where+ size (UTF16Text t) = sUTF16 t+ encode (UTF16Text t) = eUTF16 t+ decode = UTF16Text <$> dUTF16+#endif+
+ src/Flat/Instances/Unordered.hs view
@@ -0,0 +1,47 @@+module Flat.Instances.Unordered+ ()+where++import Flat.Instances.Mono+import Flat.Instances.Util+import Data.HashSet+import Data.Hashable+import qualified Data.HashMap.Strict as MS++-- $setup+-- >>> import Flat.Instances.Base()+-- >>> import Flat.Instances.Test+-- >>> import Data.Word +-- >>> import qualified Data.HashMap.Strict+-- >>> import qualified Data.HashMap.Lazy+-- >>> import qualified Data.HashSet+-- >>> let test = tstBits++{-|+>>> test (Data.HashSet.fromList [1..3::Word])+(True,28,"10000000 11000000 10100000 0110")+-}++instance (Hashable a, Eq a,Flat a) => Flat (HashSet a) where+ size = sizeSet+ encode = encodeSet+ decode = decodeSet++{-|+>>> test (Data.HashMap.Strict.fromList [(1,11),(2,22)])+(True,35,"10000001 00001011 01000001 00001011 000")++>>> test (Data.HashMap.Lazy.fromList [(1,11),(2,22)])+(True,35,"10000001 00001011 01000001 00001011 000")++-}+instance (Hashable k,Eq k,Flat k,Flat v) => Flat (MS.HashMap k v) where+ size = sizeMap+ encode = encodeMap+ decode = decodeMap++-- instance (Hashable k,Eq k,Flat k,Flat v) => Flat (ML.HashMap k v) where+-- size = sizeMap+-- encode = encodeMap+-- decode = decodeMap+
+ src/Flat/Instances/Util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TupleSections ,ViewPatterns ,NoMonomorphismRestriction ,BangPatterns ,ScopedTypeVariables #-}++module Flat.Instances.Util+ ( module F+ -- sizeList+ -- , decodeList+ -- , encodeList+ , encodeArray+ )+where++import Flat.Class as F+import Flat.Decoder as F+import Flat.Encoder as F+import Flat.Types as F+-- import Data.List+-- import GHC.Exts(IsList)++-- -- $setup+-- >>> import Flat.Instances.Base()+-- >>> import Flat.Instances.Test+-- >>> let test = tstBits++-- {-|+-- >>> test []+-- (True,1,"0")++-- >>> test [1::Word8]+-- (True,10,"10000000 10")+-- -}++-- {-# INLINE sizeList #-}+-- sizeList :: Flat a => [a] -> NumBits -> NumBits+-- sizeList l sz = foldl' (\s e -> size e (s + 1)) (sz + 1) l ++-- {-# INLINE encodeList #-}+-- encodeList :: Flat a => [a] -> Encoding+-- encodeList = encodeListWith encode++-- {-# INLINE decodeList #-}+-- decodeList :: Flat a => Get [a]+-- decodeList = decodeListWith decode++{-# INLINE encodeArray #-}+encodeArray :: Flat a => [a] -> Encoding+encodeArray = encodeArrayWith encode
+ src/Flat/Instances/Vector.hs view
@@ -0,0 +1,45 @@+-- | Flat instances for the vector package.+module Flat.Instances.Vector+ ()+where++import Flat.Instances.Mono+import Flat.Instances.Util++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as S++-- $setup+-- >>> import Flat.Instances.Test+-- >>> import Flat.Instances.Base()+-- >>> import qualified Data.Vector as V+-- >>> import qualified Data.Vector.Unboxed as U+-- >>> import qualified Data.Vector.Storable as S++{-|+Vectors are encoded as arrays.++>>> tst (V.fromList [11::Word8,22,33])+(True,40,[3,11,22,33,0])++All Vectors are encoded in the same way:++>>> let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)]+True+-}++instance Flat a => Flat (V.Vector a) where+ size = sizeSequence+ encode = encodeSequence+ decode = decodeSequence++instance (U.Unbox a,Flat a) => Flat (U.Vector a) where+ size = sizeSequence+ encode = encodeSequence+ decode = decodeSequence++instance (S.Storable a,Flat a) => Flat (S.Vector a) where+ size = sizeSequence+ encode = encodeSequence+ decode = decodeSequence
+ src/Flat/Memory.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{- |+Memory access primitives.++Includes code from the [store-core](https://hackage.haskell.org/package/store-core) package.+-}+module Flat.Memory+ ( chunksToByteString+ , chunksToByteArray+ , ByteArray+ , pokeByteArray+ , pokeByteString+ , unsafeCreateUptoN'+ , minusPtr+ , peekByteString+ )+where++import Control.Monad (foldM_, when)+import Control.Monad.Primitive (PrimMonad (..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as BS+import Data.Primitive.ByteArray (ByteArray, ByteArray#,+ MutableByteArray (..), newByteArray,+ unsafeFreezeByteArray)+import Foreign (Ptr, Word8, minusPtr, plusPtr,+ withForeignPtr)+import GHC.Prim (copyAddrToByteArray#,+ copyByteArrayToAddr#)+import GHC.Ptr (Ptr (..))+import GHC.Types (IO (..), Int (..))+import System.IO.Unsafe (unsafeDupablePerformIO,+ unsafePerformIO)++unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a)+unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f)+{-# INLINE unsafeCreateUptoN' #-}++createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a)+createUptoN' l f = do+ fp <- BS.mallocByteString l+ (l', res) <- withForeignPtr fp $ \p -> f p+ --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"])+ when (l' > l) $ error+ (unwords+ ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"]+ )+ return (BS.PS fp 0 l', res) -- , minusPtr l')+{-# INLINE createUptoN' #-}++-- |Copy bytestring to given pointer, returns new pointer+pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8)+pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer =+ do+ withForeignPtr foreignPointer $ \sourcePointer -> BS.memcpy+ destPointer+ (sourcePointer `plusPtr` sourceOffset)+ sourceLength+ return (destPointer `plusPtr` sourceLength)++{-| Create a new bytestring, copying sourceLen bytes from sourcePtr++@since 0.6+-}+peekByteString ::+ Ptr Word8 -- ^ sourcePtr+ -> Int -- ^ sourceLen+ -> BS.ByteString+peekByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength++-- |Copy ByteArray to given pointer, returns new pointer+pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8)+pokeByteArray sourceArr sourceOffset len dest = do+ copyByteArrayToAddr sourceArr sourceOffset dest len+ let !dest' = dest `plusPtr` len+ return dest'+{-# INLINE pokeByteArray #-}+++-- | Wrapper around @copyByteArrayToAddr#@ primop.+--+-- Copied from the store-core package+copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()+copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) =+ IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #))+{-# INLINE copyByteArrayToAddr #-}++chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString+chunksToByteString (sourcePtr0, lens) =+ BS.unsafeCreate (sum lens) $ \destPtr0 -> foldM_+ (\(destPtr, sourcePtr) sourceLength ->+ BS.memcpy destPtr sourcePtr sourceLength+ >> return+ ( destPtr `plusPtr` sourceLength+ , sourcePtr `plusPtr` (sourceLength + 1)+ )+ )+ (destPtr0, sourcePtr0)+ lens++chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int)+chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do+ let len = sum lens+ arr <- newByteArray len+ foldM_+ (\(destOff, sourcePtr) sourceLength ->+ copyAddrToByteArray sourcePtr arr destOff sourceLength >> return+ (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1))+ )+ (0, sourcePtr0)+ lens+ farr <- unsafeFreezeByteArray arr+ return (farr, len)+++-- | Wrapper around @copyAddrToByteArray#@ primop.+--+-- Copied from the store-core package+copyAddrToByteArray+ :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO ()+copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) =+ IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #))+{-# INLINE copyAddrToByteArray #-}
+ src/Flat/Run.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |Encoding and decoding functions+module Flat.Run (+ flat,+ flatRaw,+ unflat,+ unflatWith,+ unflatRaw,+ unflatRawWith,+ unflatRawWithOffset,+) where++import qualified Data.ByteString as B+import Data.ByteString.Convert (AsByteString (..))+import Flat.Class (Flat (decode, encode), getSize)+import Flat.Decoder (Decoded, Get, strictDecoder)+import Flat.Encoder (NumBits)+import qualified Flat.Encoder as E+import Flat.Filler (postAligned, postAlignedDecoder)++-- |Encode padded value.+flat :: Flat a => a -> B.ByteString+flat = flatRaw . postAligned++-- |Decode padded value.+unflat :: (Flat a, AsByteString b) => b -> Decoded a+unflat = unflatWith decode++-- |Decode padded value, using the provided unpadded decoder.+unflatWith :: AsByteString b => Get a -> b -> Decoded a+unflatWith dec = unflatRawWith (postAlignedDecoder dec)++-- |Decode unpadded value.+unflatRaw :: (Flat a, AsByteString b) => b -> Decoded a+unflatRaw = unflatRawWith decode++-- |Unflat unpadded value, using provided decoder+unflatRawWith :: AsByteString b => Get a -> b -> Decoded a+unflatRawWith dec bs = unflatRawWithOffset dec bs 0++unflatRawWithOffset :: AsByteString b => Get a -> b -> NumBits -> Decoded a+unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs)++-- unflatRawWith :: AsByteString b => Get a -> b -> Decoded a+-- unflatRawWith dec bs = unflatRawWithOffset dec bs 0++-- unflatRawWithOffset :: AsByteString b => Get a -> b -> Int -> Decoded a+-- unflatRawWithOffset dec bs = strictDecoder dec (toByteString bs)++-- |Encode unpadded value+flatRaw :: (Flat a, AsByteString b) => a -> b+flatRaw a =+ fromByteString $+ E.strictEncoder+ (getSize a)++#ifdef ETA_VERSION+ (E.trampolineEncoding (encode a))+#else+ (encode a)+#endif++-- #ifdef ETA_VERSION+-- deriving (Show, Eq, Ord, Typeable, Generic, NFData)++-- instance Flat a => Flat (PostAligned a) where+-- encode (PostAligned val fill) = trampolineEncoding (encode val) <> encode fill++-- #else+-- deriving (Show, Eq, Ord, Typeable, Generic, NFData,Flat)+-- #endif
+ src/Flat/Tutorial.hs view
@@ -0,0 +1,116 @@+module Flat.Tutorial+ (+ -- $setup++ -- $main+ )+where+++{- $setup+To (de)serialise a data type, make it an instance of the 'Flat.Class.Flat' class.++There is <https://hackage.haskell.org/package/base/docs/GHC-Generics.html Generics> based support to automatically derive a correct instance.++Let’s see some code.++We need a couple of extensions:++>>> :set -XDeriveGeneric -XDeriveAnyClass++The @Flat@ top module:++>>> import Flat++And, just for fun, a couple of functions to display an encoded value as a sequence of bits:++>>> import Flat.Instances.Test (flatBits,allBits)++Define a few custom data types, deriving @Generic@ and @Flat@:++>>> data Result = Bad | Good deriving (Show,Generic,Flat)++>>> data Direction = North | South | Center | East | West deriving (Show,Generic,Flat)++>>> data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat)+-}++{- $main+Now we can encode a List of Directions using 'Flat.Run.flat':++>>> flat $ Cons North (Cons South Nil)+"\149"++The result is a strict <https://hackage.haskell.org/package/bytestring/docs/Data-ByteString.html ByteString>.++And decode it back using 'Flat.Run.unflat':++>>> unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction)+Right (Cons North (Cons South Nil))++The result is a 'Flat.Decoded' value: 'Either' a 'Flat.DecodeException' or the actual value.++=== Optimal Bit-Encoding+#optimal-bit-encoding#++A pecularity of Flat is that it uses an optimal bit-encoding rather than+the usual byte-oriented one.++One bit is sufficient to encode a 'Result' or an empty 'List':++>>> flatBits Good+"1"++>>> flatBits (Nil::List Direction)+"0"++Two or three bits suffice for a 'Direction':++>>> flatBits South+"01"++>>> flatBits West+"111"++For the serialisation to work with byte-oriented devices or storage, we need to add some padding.++To do so, rather than encoding a plain value, 'Flat.Run.flat' encodes a 'Flat.Filler.PostAligned' value, that's to say a value followed by a 'Flat.Filler.Filler' that stretches till the next byte boundary.++In practice, the padding is a, possibly empty, sequence of 0s followed by a 1.++For example, this list encodes as 7 bits:++>>> flatBits $ Cons North (Cons South Nil)+"1001010"++And, with the added padding of a final "1", will snugly fit in a single byte:++>>> allBits $ Cons North (Cons South Nil)+"10010101"++But .. you don't need to worry about these details as byte-padding is automatically added by the function 'Flat.Run.flat' and removed by 'Flat.Run.unflat'.++=== Pre-defined Instances++Flat instances are already defined for relevant types of some common packages: array, base, bytestring, containers, dlist, mono-traversable, text, unordered-containers, vector.++They are automatically imported by the "Flat" module.++For example:++>>> flatBits $ Just True+"11"++=== Wrapper Types++There are a few wrapper types that modify the way encoding and/or decoding occur.++* "Flat.AsBin" and "Flat.AsSize" decode to a value's flat binary representation or size in bits respectively.++* 'Flat.Instances.Mono.AsArray' and 'Flat.Instances.Mono.AsList' encode/decode a sequence as a List or Array respectively, see "Flat.Instances.Mono" for details.++* 'Flat.Instances.Text.UTF8Text' and 'Flat.Instances.Text.UTF16Text' encode/decode a Text as UTF8 or UTF16 respectively.++-}++
+ src/Flat/Types.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+-- |Common Types+module Flat.Types (+ NumBits,+ module Data.Word,+ module Data.Int,+ Natural,+ SBS.ShortByteString,+ T.Text,+ ) where++import qualified Data.ByteString.Short.Internal as SBS+import Data.Int+import qualified Data.Text as T+import Data.Word+import Numeric.Natural++-- |Number of bits+type NumBits = Int+
stack.yaml view
@@ -1,13 +1,43 @@-#resolver: lts-9.21-resolver: lts-11.22-#resolver: lts-12.16-# resolver: nightly-2018-11-02+# For ghc 7.10.3, use cabal instead +# Supported stack versions++# resolver: lts-9.21 # ghc 8.0.2++# resolver: lts-11.22 # ghc 8.2.2++# resolver: lts-12.26 # ghc 8.4.4++# resolver: lts-14.27 # ghc 8.6.5++# resolver: lts-16.31 # ghc 8.8.4++resolver: lts-18.28 # ghc 8.10.7++# resolver: lts-19.26 # ghc 9.0.2++# resolver: nightly-2022-09-30 # ghc 9.2.4++packages:+ - .++ # for test only+ #- ../EXTERNAL/doctest+ extra-deps:-#- QuickCheck-2.12.6.1@sha256:95b4e3b01033bf7d2ad21d0085266dba378477ac88e3d11ff238fc9db2575e6d-# Required to avoid problem with Natural instance in QuickCheck-- QuickCheck-2.11.3@sha256:e4c56f52532c993fc4460aeac7a2543dc03a68fba36eff420f3294d4d2622416-- tasty-1.1.0.4@sha256:1310ceed449b3227614b329a1672a2c5bb046cb49e281996523567b3b0ad9ecc-- tasty-quickcheck-0.10@sha256:9ddbacf1504bbbc4b99ab447d26651ad8454b69ceced3486e4623dccb89fb3d9-- optparse-applicative-0.14.3.0@sha256:b6b56a922d10911a2824b965750ddc7794de746e347afe67f1a84d05168368dc-- wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3+ # Modified doctest, used to generate static tests (run by doc-static)+ - hashable-1.4.0.2@sha256:0cddd0229d1aac305ea0404409c0bbfab81f075817bd74b8b2929eff58333e55,5005+ - git: https://github.com/tittoassini/doctest+ commit: 3954e94449901764e28cfed1c35490af970e9b01++ # for ghcjs-cons+ # - jsaddle-0.9.8.2@sha256:e8c003801eb9364fcd6b1e0cda34f072a537bcfa767e6eb8c626836dae77ba04,4419+ # - ref-tf-0.4.0.2@sha256:69de3550250e0cd69f45d080359cb314a9487c915024349c75b78732bbee9332,1134++ # for text-2.0:+ # - text-2.0.1+ # - Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459+ # - parsec-3.1.15.0@sha256:a162d4cc8884014ba35192545cad293af0529fe11497aad8834bbaaa3dfffc26,4429+ # - hashable-1.4.1.0@sha256:50b2f002c68fe67730ee7a3cd8607486197dd99b084255005ad51ecd6970a41b,5019++allow-newer: true
+ test/Big.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+Test different ways of handlings a data type that has large values and a small encoding.++To run with limited memory: cabal run big -- +RTS -M2g+-}++module Main where+import qualified Data.ByteString as B+import Data.List (foldl')+import Flat (Decoded, Flat (..), flat, unflat, unflatWith)+import Flat.AsBin (AsBin, unbin)+import Flat.AsSize+import Flat.Decoder (Get, listTDecoder)+import qualified ListT as L+import System.TimeIt (timeIt)++-- Big is a type that has a small encoded representation but a very large in-memory footprint.+-- It is a very large bytestring whose bytes are all set to 0+newtype Big = Big B.ByteString++newBig :: Int -> Big+newBig gigas = Big $ B.replicate (gigas*giga) 0++-- length of Big in gigas+gigas :: Big -> Int+gigas (Big b) = B.length b `div` giga++giga :: Int+giga = 1000000000++instance Show Big where show b = "Big of " ++ show (gigas b) ++ "Gbytes"++instance Flat Big where+ -- The encoded form is just the number of giga zeros (e.g. 5 for 5Giga zeros)+ size big = size (gigas big)+ encode big = encode (gigas big)++ -- The decoded form is massive+ decode = newBig <$> decode++main :: IO ()+main = tbig++tbig = do+ let numOfBigs = 5++ -- A serialised list of Big values+ let bigsFile = flat $ replicate numOfBigs $ newBig 1+ print "Encoding Time"+ timeIt $ print $ B.length bigsFile++ tstAsSize bigsFile++ tstAsBin bigsFile++ tstListT bigsFile++ tstBig bigsFile++-- If we unserialise a list of Bigs and then process them (e.g. print them out) we end up in trouble, too much memory is required.+tstBig :: B.ByteString -> IO ()+tstBig bigsFile = timeIt $ do+ print "Decode to [Big]:"+ let Right (bs :: [Big]) = unflat bigsFile+ mapM_ print bs++-- So instead we unserialise them to a list of their flat representations, to be unflatted on demand later on+tstAsBin :: B.ByteString -> IO ()+tstAsBin bigsFile = timeIt $ do+ print "Decode to [AsBin Big]:"+ let Right (bsR :: [AsBin Big]) = unflat bigsFile+ let bs = map unbin bsR+ mapM_ print bs++tstAsSize :: B.ByteString -> IO ()+tstAsSize bigsFile = timeIt $ do+ print "Decode to [AsSize Big]:"+ let Right (bs :: [AsSize Big]) = unflat bigsFile+ mapM_ print bs++-- Or: we extract one element at the time via a ListT+-- See http://hackage.haskell.org/package/list-t-1.0.4/docs/ListT.html+tstListT :: B.ByteString -> IO ()+tstListT bigsFile = timeIt $ do+ print "Decode to ListT IO Big:"+ stream :: L.ListT IO Big <- listTDecoder decode bigsFile+ L.traverse_ print stream
+ test/DocTest.hs view
@@ -0,0 +1,169 @@++-- Execute doctest tests with no dependencies on doctest+-- TODO: move in a different doctest-static package+{-# LANGUAGE OverloadedStrings ,DeriveFunctor#-}+{-# LANGUAGE FlexibleInstances,UndecidableInstances #-}+-- move to doctest+module DocTest+ ( asPrint+ , test+ , testProp+ , LineChunk(..)+ , ExpectedLine(..)+ )+where+import qualified Data.Text as T+import Test.Tasty+import Test.Tasty.HUnit++import Test.Tasty.QuickCheck+-- import Runner.Example+import Data.Char+import Data.List+import Data.String++class Print f where+ asPrint :: f -> IO String++instance Show a => Print (IO a) where+ asPrint io = io >>= return . show++instance {-# OVERLAPPABLE #-} Show a => Print a where+ asPrint a = return (show a)++{-++-}+-- test :: TestName -> ExpectedResult -> IO String -> IO TestTree+test :: TestName -> String -> IO String -> IO TestTree+test loc expectedS valIO = do+ let expected = read expectedS+ actual <- lines <$> valIO+ return $ testCase loc (mkResult expected actual @=? Equal)+ -- return $ testCase loc (unlines exp @=? unlines actual)++testProp :: Testable t => TestName -> t -> IO TestTree+testProp loc = return . testProperty loc+++-- Code copied and adapted by doctest++data Result = Equal | NotEqual [String]+ deriving (Eq, Show,Read)++-- | Remove trailing white space from a string.+--+-- >>> stripEnd "foo "+-- "foo"+stripEnd :: String -> String+stripEnd = reverse . dropWhile isSpace . reverse++mkResult :: ExpectedResult -> [String] -> Result+mkResult expected actual | expected `matches` actual = Equal+ | otherwise = NotEqual (formatNotEqual expected actual)+ where+ chunksMatch :: [LineChunk] -> String -> Bool+ chunksMatch [] "" = True+ chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys+ chunksMatch (LineChunk x : xs) ys =+ x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys+ chunksMatch zs@(WildCardChunk : xs) (_ : ys) =+ xs `chunksMatch` ys || zs `chunksMatch` ys+ chunksMatch _ _ = False++ matches :: ExpectedResult -> [String] -> Bool+ matches (ExpectedLine x : xs) (y : ys) = x `chunksMatch` y && xs `matches` ys+ matches (WildCardLine : xs) ys | xs `matches` ys = True+ matches zs@(WildCardLine : _) (_ : ys) = zs `matches` ys+ matches [] [] = True+ matches [] _ = False+ matches _ [] = False+++formatNotEqual :: ExpectedResult -> [String] -> [String]+formatNotEqual expected_ actual =+ formatLines "expected: " expected ++ formatLines " but got: " actual+ where+ expected :: [String]+ expected = map+ (\x -> case x of+ ExpectedLine str -> concatMap lineChunkToString str+ WildCardLine -> "..."+ )+ expected_++ -- use show to escape special characters in output lines if any output line+ -- contains any unsafe character+ escapeOutput | any (not . isSafe) (concat $ expected ++ actual) = map show+ | otherwise = id++ isSafe :: Char -> Bool+ isSafe c = c == ' ' || (isPrint c && (not . isSpace) c)++ formatLines :: String -> [String] -> [String]+ formatLines message xs = case escapeOutput xs of+ y : ys -> (message ++ y) : map (padding ++) ys+ [] -> [message]+ where padding = replicate (length message) ' '++lineChunkToString :: LineChunk -> String+lineChunkToString WildCardChunk = "..."+lineChunkToString (LineChunk str) = str++-- import Control.DeepSeq (deepseq, NFData(rnf))++-- | A thing with a location attached.+data Located a = Located Location a+ deriving (Eq, Show, Functor)++-- instance NFData a => NFData (Located a) where+-- rnf (Located loc a) = loc `deepseq` a `deepseq` ()++-- | Discard location information.+unLoc :: Located a -> a+unLoc (Located _ a) = a++-- | Add dummy location information.+noLocation :: a -> Located a+noLocation = Located (UnhelpfulLocation "<no location info>")++-- | A line number.+type Line = Int++-- | A combination of file name and line number.+data Location = UnhelpfulLocation String | Location FilePath Line+ deriving Eq++instance Show Location where+ show (UnhelpfulLocation s) = s+ show (Location file line ) = file ++ ":" ++ show line++-- instance NFData Location where+-- rnf (UnhelpfulLocation str) = str `deepseq` ()+-- rnf (Location file line ) = file `deepseq` line `deepseq` ()++-- |+-- Create a list from a location, by repeatedly increasing the line number by+-- one.+enumerate :: Location -> [Location]+enumerate loc = case loc of+ UnhelpfulLocation _ -> repeat loc+ Location file line -> map (Location file) [line ..]++data DocTest = Example Expression ExpectedResult | Property Expression+ deriving (Eq, Show,Read)++data LineChunk = LineChunk String | WildCardChunk+ deriving (Show, Eq,Read)++instance IsString LineChunk where+ fromString = LineChunk++data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine+ deriving (Show, Eq,Read)++instance IsString ExpectedLine where+ fromString = ExpectedLine . return . LineChunk++type Expression = String+type ExpectedResult = [ExpectedLine]
+ test/DocTest/Data/FloatCast.hs view
@@ -0,0 +1,11 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Data.FloatCast where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Data.FloatCast+import Numeric (showHex)+import Data.Word++tests :: IO TestTree+tests = testGroup "Data.FloatCast" <$> sequence [ DocTest.testProp "src/Data/FloatCast.hs:35" ( \f -> wordToFloat (floatToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:38" "[ExpectedLine [LineChunk \"3189768192\"]]" (DocTest.asPrint( floatToWord (-0.15625) )), DocTest.test "src/Data/FloatCast.hs:41" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToFloat 3189768192 )), DocTest.test "src/Data/FloatCast.hs:44" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( floatToWord (-5.828125) == 0xC0BA8000 )), DocTest.testProp "src/Data/FloatCast.hs:63" ( \f -> wordToDouble (doubleToWord f ) == f ), DocTest.test "src/Data/FloatCast.hs:66" "[ExpectedLine [LineChunk \"\\\"3ff0000000000002\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord 1.0000000000000004) "" )), DocTest.test "src/Data/FloatCast.hs:69" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( doubleToWord 1.0000000000000004 == 0x3FF0000000000002 )), DocTest.test "src/Data/FloatCast.hs:72" "[ExpectedLine [LineChunk \"\\\"bfc4000000000000\\\"\"]]" (DocTest.asPrint( showHex (doubleToWord (-0.15625)) "" )), DocTest.test "src/Data/FloatCast.hs:75" "[ExpectedLine [LineChunk \"-0.15625\"]]" (DocTest.asPrint( wordToDouble 0xbfc4000000000000 )), DocTest.test "src/Data/FloatCast.hs:90" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( runST (cast (0xF0F1F2F3F4F5F6F7::Word64)) == (0xF0F1F2F3F4F5F6F7::Word64) ))]
+ test/DocTest/Data/ZigZag.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE NegativeLiterals,ScopedTypeVariables,FlexibleContexts#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Data.ZigZag where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Data.ZigZag+import Data.Word+import Data.Int+import Numeric.Natural+import Test.QuickCheck.Arbitrary+instance Arbitrary Natural where arbitrary = arbitrarySizedNatural; shrink = shrinkIntegral++tests :: IO TestTree+tests = testGroup "Data.ZigZag" <$> sequence [ DocTest.testProp "src/Data/ZigZag.hs:67" ( \(f::Integer) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:70" ( \(f::Natural) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:73" ( \(f::Int8) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:76" ( \(f::Word8) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:79" ( \(s::Int8) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:82" ( \(u::Word8) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.testProp "src/Data/ZigZag.hs:85" ( \(f::Int64) -> zagZig (zigZag f) == f ), DocTest.testProp "src/Data/ZigZag.hs:88" ( \(f::Word64) -> zigZag (zagZig f) == f ), DocTest.testProp "src/Data/ZigZag.hs:91" ( \(s::Int64) -> zigZag s == fromIntegral (zigZag (fromIntegral s :: Integer)) ), DocTest.testProp "src/Data/ZigZag.hs:94" ( \(u::Word64) -> zagZig u == fromIntegral (zagZig (fromIntegral u :: Natural)) ), DocTest.test "src/Data/ZigZag.hs:34" "[ExpectedLine [LineChunk \"0\"]]" (DocTest.asPrint( zigZag (0::Int8) )), DocTest.test "src/Data/ZigZag.hs:37" "[ExpectedLine [LineChunk \"1\"]]" (DocTest.asPrint( zigZag (-1::Int16) )), DocTest.test "src/Data/ZigZag.hs:40" "[ExpectedLine [LineChunk \"2\"]]" (DocTest.asPrint( zigZag (1::Int32) )), DocTest.test "src/Data/ZigZag.hs:43" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( zigZag (-2::Int16) )), DocTest.test "src/Data/ZigZag.hs:46" "[ExpectedLine [LineChunk \"99\"]]" (DocTest.asPrint( zigZag (-50::Integer) )), DocTest.test "src/Data/ZigZag.hs:49" "[ExpectedLine [LineChunk \"100\"]]" (DocTest.asPrint( zigZag (50::Integer) )), DocTest.test "src/Data/ZigZag.hs:52" "[ExpectedLine [LineChunk \"128\"]]" (DocTest.asPrint( zigZag (64::Integer) )), DocTest.test "src/Data/ZigZag.hs:55" "[ExpectedLine [LineChunk \"511\"]]" (DocTest.asPrint( zigZag (-256::Integer) )), DocTest.test "src/Data/ZigZag.hs:58" "[ExpectedLine [LineChunk \"512\"]]" (DocTest.asPrint( zigZag (256::Integer) )), DocTest.test "src/Data/ZigZag.hs:61" "[ExpectedLine [LineChunk \"[5,3,1,0,2,4,6]\"]]" (DocTest.asPrint( map zigZag [-3..3::Integer] )), DocTest.test "src/Data/ZigZag.hs:64" "[ExpectedLine [LineChunk \"[0,-1,1,-2,2,-3,3]\"]]" (DocTest.asPrint( map zagZig [0..6::Word8] ))]
+ test/DocTest/Flat/AsBin.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE ScopedTypeVariables#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.AsBin where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.AsBin+import Flat.Instances.Base+import Flat.Instances.Text+import Flat.Decoder.Types+import Flat.Types+import Flat.Run+import Data.Word+import qualified Data.Text as T+import Text.PrettyPrint.HughesPJClass++tests :: IO TestTree+tests = testGroup "Flat.AsBin" <$> sequence [ DocTest.test "src/Flat/AsBin.hs:50" "[ExpectedLine [LineChunk \"Right [AsBin {repr = \\\"\\\\129A\\\", offsetBits = 1},AsBin {repr = \\\"A \\\", offsetBits = 2},AsBin {repr = \\\" \\\\193\\\", offsetBits = 3}]\"]]" (DocTest.asPrint( unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int]) )), DocTest.test "src/Flat/AsBin.hs:55" "[ExpectedLine [LineChunk \"Right 'a'\"]]" (DocTest.asPrint( unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char)) )), DocTest.test "src/Flat/AsBin.hs:60" "[ExpectedLine [LineChunk \"3\"]]" (DocTest.asPrint( let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l !! 2) )), DocTest.test "src/Flat/AsBin.hs:65" "[ExpectedLine [LineChunk \"\\\"(0, _0000001 1, _1)\\\"\"]]" (DocTest.asPrint( let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t )), DocTest.test "src/Flat/AsBin.hs:80" "[ExpectedLine [LineChunk \"Right (AsBin {repr = \\\"\\\", offsetBits = 0})\"]]" (DocTest.asPrint( unflat (flat ()) :: Decoded (AsBin ()) )), DocTest.test "src/Flat/AsBin.hs:83" "[ExpectedLine [LineChunk \"Right (False,AsBin {repr = \\\"A\\\", offsetBits = 1})\"]]" (DocTest.asPrint( unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool) )), DocTest.test "src/Flat/AsBin.hs:86" "[ExpectedLine [LineChunk \"Right (False,False,AsBin {repr = \\\"?\\\\193\\\", offsetBits = 2})\"]]" (DocTest.asPrint( unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8) )), DocTest.test "src/Flat/AsBin.hs:89" "[ExpectedLine [LineChunk \"(False,False,255,True)\"]]" (DocTest.asPrint( let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3) ))]
+ test/DocTest/Flat/AsSize.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ScopedTypeVariables#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.AsSize where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.AsSize+import Flat.Instances.Base+import Flat.Instances.Text+import Flat.Decoder.Types+import Flat.Types+import Flat.Run+import Data.Word+import qualified Data.Text as T++tests :: IO TestTree+tests = testGroup "Flat.AsSize" <$> sequence [ DocTest.test "src/Flat/AsSize.hs:38" "[ExpectedLine [LineChunk \"Right ('a',AsSize 28,'z',AsSize 1)\"]]" (DocTest.asPrint( let v = flat ('a',"abc",'z',True) in unflat v :: Decoded (Char,AsSize String,Char,AsSize Bool) )), DocTest.test "src/Flat/AsSize.hs:43" "[ExpectedLine [LineChunk \"Right (AsSize 8,AsSize 8)\"]]" (DocTest.asPrint( unflat (flat (1::Word16,1::Word64)) :: Decoded (AsSize Word16,AsSize Word64) )), DocTest.test "src/Flat/AsSize.hs:48" "[ExpectedLine [LineChunk \"Right (AsSize 16,AsSize 32,AsSize 48,AsSize 48,AsSize 40,AsSize 40)\"]]" (DocTest.asPrint( unflat (flat (T.pack "",T.pack "a",T.pack "主",UTF8Text $ T.pack "主",UTF16Text $ T.pack "主",UTF16Text $ T.pack "a")) :: Decoded (AsSize T.Text,AsSize T.Text,AsSize T.Text,AsSize UTF8Text,AsSize UTF16Text,AsSize UTF16Text) )), DocTest.test "src/Flat/AsSize.hs:53" "[ExpectedLine [LineChunk \"Right (AsSize 1,AsSize 96,AsSize 8)\"]]" (DocTest.asPrint( unflat (flat (False,[T.pack "",T.pack "a",T.pack "主"],'a')) :: Decoded (AsSize Bool,AsSize [T.Text],AsSize Char) ))]
+ test/DocTest/Flat/Bits.hs view
@@ -0,0 +1,12 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Bits where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Bits+import Data.Word+import Flat.Instances.Base+import Flat.Instances.Test(tst,prettyShow)++tests :: IO TestTree+tests = testGroup "Flat.Bits" <$> sequence [ DocTest.test "src/Flat/Bits.hs:50" "[ExpectedLine [LineChunk \"[True]\"]]" (DocTest.asPrint( bits True )), DocTest.test "src/Flat/Bits.hs:62" "[ExpectedLine [LineChunk \"[True,False,False,False,False,False,False,True]\"]]" (DocTest.asPrint( paddedBits True )), DocTest.test "src/Flat/Bits.hs:82" "[ExpectedLine [LineChunk \"[False,False,False,False,False,True,False,True]\"]]" (DocTest.asPrint( asBits (5::Word8) )), DocTest.test "src/Flat/Bits.hs:90" "[ExpectedLine [LineChunk \"[1,3]\"]]" (DocTest.asPrint( asBytes $ asBits (256+3::Word16) )), DocTest.test "src/Flat/Bits.hs:106" "[ExpectedLine [LineChunk \"\\\"00000001 00000011\\\"\"]]" (DocTest.asPrint( prettyShow $ asBits (256+3::Word16) ))]
+ test/DocTest/Flat/Decoder/Prim.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE BinaryLiterals#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Decoder.Prim where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Decoder.Prim+import Data.Word+import Data.Int+import Flat.Run+import Flat.Bits+import Text.PrettyPrint.HughesPJClass (Pretty (pPrint))++tests :: IO TestTree+tests = testGroup "Flat.Decoder.Prim" <$> sequence [ DocTest.test "src/Flat/Decoder/Prim.hs:198" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( unflatWith (dBEBits8 3) [0b11100001::Word8] == Right 0b00000111 )), DocTest.test "src/Flat/Decoder/Prim.hs:201" "[ExpectedLine [LineChunk \"Left (BadOp \\\"read8: cannot read 9 bits\\\")\"]]" (DocTest.asPrint( unflatWith (dBEBits8 9) [0b11100001::Word8,0b11111111] )), DocTest.test "src/Flat/Decoder/Prim.hs:214" "[ExpectedLine [LineChunk \"Right 00000101 10111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 11) [0b10110111::Word8,0b11100001] )), DocTest.test "src/Flat/Decoder/Prim.hs:219" "[ExpectedLine [LineChunk \"Right 00000111 11111111\"]]" (DocTest.asPrint( pPrint . asBits <$> unflatWith (dBEBits16 19) [0b00000000::Word8,0b11111111,0b11100001] ))]
+ test/DocTest/Flat/Encoder/Prim.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Encoder.Prim where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Encoder.Prim+import Flat.Instances.Test+import Flat.Bits+import Flat.Encoder.Strict+import Control.Monad+enc e = prettyShow $ encBits 256 (Encoding e)++tests :: IO TestTree+tests = testGroup "Flat.Encoder.Prim" <$> sequence [ DocTest.test "src/Flat/Encoder/Prim.hs:371" "[ExpectedLine [LineChunk \"\\\"1\\\"\"]]" (DocTest.asPrint( enc eTrueF )), DocTest.test "src/Flat/Encoder/Prim.hs:379" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( enc eFalseF )), DocTest.test "src/Flat/Encoder/Prim.hs:389" "[ExpectedLine [LineChunk \"\\\"10000001\\\"\"]]" (DocTest.asPrint( enc $ eTrueF >=> eFillerF )), DocTest.test "src/Flat/Encoder/Prim.hs:392" "[ExpectedLine [LineChunk \"\\\"00000001\\\"\"]]" (DocTest.asPrint( enc eFillerF )), DocTest.test "src/Flat/Encoder/Prim.hs:425" "[ExpectedLine [LineChunk \"\\\"11111111\\\"\"]]" (DocTest.asPrint( enc $ \s-> eWord8F 0 s >>= updateWord8 255 s )), DocTest.test "src/Flat/Encoder/Prim.hs:428" "[ExpectedLine [LineChunk \"\\\"10000000 01111111 1\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eWord8F 255 >>= updateWord8 0 s1 )), DocTest.test "src/Flat/Encoder/Prim.hs:431" "[ExpectedLine [LineChunk \"\\\"01111111 1\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 )), DocTest.test "src/Flat/Encoder/Prim.hs:434" "[ExpectedLine [LineChunk \"\\\"01111111 10\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eFalseF s0 >>= \s1 -> eWord8F 0 s1 >>= updateWord8 255 s1 >>= eFalseF )), DocTest.test "src/Flat/Encoder/Prim.hs:437" "[ExpectedLine [LineChunk \"\\\"10000000 011\\\"\"]]" (DocTest.asPrint( enc $ \s0 -> eTrueF s0 >>= \s1 -> eWord8F 255 s1 >>= eTrueF >>= updateWord8 0 s1 >>= eTrueF ))]
+ test/DocTest/Flat/Endian.hs view
@@ -0,0 +1,10 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Endian where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Endian+import Numeric (showHex)++tests :: IO TestTree+tests = testGroup "Flat.Endian" <$> sequence [ DocTest.test "src/Flat/Endian.hs:38" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE64 0xF0F1F2F3F4F5F6F7 == if isBigEndian then 0xF0F1F2F3F4F5F6F7 else 0xF7F6F5F4F3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:51" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE32 0xF0F1F2F3 == if isBigEndian then 0xF0F1F2F3 else 0xF3F2F1F0 )), DocTest.test "src/Flat/Endian.hs:64" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( toBE16 0xF0F1 == if isBigEndian then 0xF0F1 else 0xF1F0 ))]
+ test/DocTest/Flat/Instances/Array.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Array where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Array+import Flat.Instances.Test+import Flat.Instances.Mono+import qualified Data.Array as A+import qualified Data.Array.Unboxed as U+import Data.Array.IArray+import Data.Word++tests :: IO TestTree+tests = testGroup "Flat.Instances.Array" <$> sequence [ DocTest.test "src/Flat/Instances/Array.hs:31" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let arr = A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] in tst (bounds arr,AsArray(elems arr)) == tst arr )), DocTest.test "src/Flat/Instances/Array.hs:36" "[ExpectedLine [LineChunk \"(True,80,[1,4,2,5,4,11,22,33,44,0])\"]]" (DocTest.asPrint( tst $ A.array ((1::Word,4::Word),(2,5)) [((1,4),11::Word),((1,5),22),((2,4),33),((2,5),44)] )), DocTest.test "src/Flat/Instances/Array.hs:39" "[ExpectedLine [LineChunk \"(True,160,[2,8,4,10,4,152,203,166,137,140,186,106,153,75,166,137,148,186,106,0])\"]]" (DocTest.asPrint( tst $ A.array ((1,4),(2,5)) [((1,4),"1.4"),((1,5),"1.5"),((2,4),"2.4"),((2,5),"2.5")] )), DocTest.test "src/Flat/Instances/Array.hs:44" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let bounds = ((1::Word,4::Word),(2,5));elems=[11::Word,22,33,44] in tst (U.listArray bounds elems :: U.UArray (Word,Word) Word) == tst (A.listArray bounds elems) ))]
+ test/DocTest/Flat/Instances/Base.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE NegativeLiterals,TypeApplications#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Base where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Base+import Flat.Instances.Test+import Data.Fixed+import Data.Int+import Data.Complex(Complex(..))+import Numeric.Natural+import Data.Word+import Data.Ratio+import Flat.Run+import Data.Monoid+import qualified Data.List.NonEmpty as B+test = tstBits+y = 33++tests :: IO TestTree+tests = testGroup "Flat.Instances.Base" <$> sequence [ DocTest.test "src/Flat/Instances/Base.hs:73" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:76" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w )), DocTest.test "src/Flat/Instances/Base.hs:148" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test () )), DocTest.test "src/Flat/Instances/Base.hs:161" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test False )), DocTest.test "src/Flat/Instances/Base.hs:164" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test True )), DocTest.test "src/Flat/Instances/Base.hs:179" "[ExpectedLine [LineChunk \"(True,8,\\\"01100001\\\")\"]]" (DocTest.asPrint( test 'a' )), DocTest.test "src/Flat/Instances/Base.hs:184" "[ExpectedLine [LineChunk \"(True,16,\\\"11001000 00000001\\\")\"]]" (DocTest.asPrint( test 'È' )), DocTest.test "src/Flat/Instances/Base.hs:187" "[ExpectedLine [LineChunk \"(True,24,\\\"10001101 10011100 00000001\\\")\"]]" (DocTest.asPrint( test '不' )), DocTest.test "src/Flat/Instances/Base.hs:191" "[ExpectedLine [LineChunk \"(True,26,\\\"11000000 01110110 00000011 10\\\")\"]]" (DocTest.asPrint( test "\x1F600" )), DocTest.test "src/Flat/Instances/Base.hs:203" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (Nothing::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:206" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (Just False::Maybe Bool) )), DocTest.test "src/Flat/Instances/Base.hs:212" "[ExpectedLine [LineChunk \"(True,2,\\\"00\\\")\"]]" (DocTest.asPrint( test (Left False::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:215" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test (Right ()::Either Bool ()) )), DocTest.test "src/Flat/Instances/Base.hs:221" "[ExpectedLine [LineChunk \"(True,16,\\\"11110110 00000001\\\")\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) )), DocTest.test "src/Flat/Instances/Base.hs:224" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) )), DocTest.test "src/Flat/Instances/Base.hs:237" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:240" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (255::Word8) )), DocTest.test "src/Flat/Instances/Base.hs:284" "[ExpectedLine [LineChunk \"(True,8,\\\"01111111\\\")\"]]" (DocTest.asPrint( test (127::Word) )), DocTest.test "src/Flat/Instances/Base.hs:289" "[ExpectedLine [LineChunk \"(True,16,\\\"11111110 00000001\\\")\"]]" (DocTest.asPrint( test (254::Word) )), DocTest.test "src/Flat/Instances/Base.hs:294" "[ExpectedLine [LineChunk \"(True,24,\\\"10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (32768::Word32) )), DocTest.test "src/Flat/Instances/Base.hs:299" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] )), DocTest.test "src/Flat/Instances/Base.hs:305" "[ExpectedLine [LineChunk \"Right 65535\"]]" (DocTest.asPrint( unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:308" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:311" "[ExpectedLine [LineChunk \"Right 4294967295\"]]" (DocTest.asPrint( unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:314" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:317" "[ExpectedLine [LineChunk \"Right 18446744073709551615\"]]" (DocTest.asPrint( unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:320" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:325" "[ExpectedLine [LineChunk \"Right 32767\"]]" (DocTest.asPrint( unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:328" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:331" "[ExpectedLine [LineChunk \"Right 2147483647\"]]" (DocTest.asPrint( unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:334" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:337" "[ExpectedLine [LineChunk \"Right 9223372036854775807\"]]" (DocTest.asPrint( unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound) )), DocTest.test "src/Flat/Instances/Base.hs:340" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound + 1) )), DocTest.test "src/Flat/Instances/Base.hs:344" "[ExpectedLine [LineChunk \"Right (-32768)\"]]" (DocTest.asPrint( unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound) )), DocTest.test "src/Flat/Instances/Base.hs:347" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound - 1) )), DocTest.test "src/Flat/Instances/Base.hs:350" "[ExpectedLine [LineChunk \"Right (-2147483648)\"]]" (DocTest.asPrint( unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound) )), DocTest.test "src/Flat/Instances/Base.hs:353" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound - 1) )), DocTest.test "src/Flat/Instances/Base.hs:356" "[ExpectedLine [LineChunk \"Right (-9223372036854775808)\"]]" (DocTest.asPrint( unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound) )), DocTest.test "src/Flat/Instances/Base.hs:359" "[ExpectedLine [LineChunk \"Left (BadEncoding \",WildCardChunk]]" (DocTest.asPrint( unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound - 1) )), DocTest.test "src/Flat/Instances/Base.hs:372" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:375" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (2^120::Natural) )), DocTest.test "src/Flat/Instances/Base.hs:425" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int) )), DocTest.test "src/Flat/Instances/Base.hs:428" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:431" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int) )), DocTest.test "src/Flat/Instances/Base.hs:434" "[ExpectedLine [LineChunk \"(True,8,\\\"00000011\\\")\"]]" (DocTest.asPrint( test (-2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:437" "[ExpectedLine [LineChunk \"(True,8,\\\"00000100\\\")\"]]" (DocTest.asPrint( test (2::Int) )), DocTest.test "src/Flat/Instances/Base.hs:450" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:453" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:456" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:459" "[ExpectedLine [LineChunk \"(True,8,\\\"00011111\\\")\"]]" (DocTest.asPrint( test (-(2^4)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:462" "[ExpectedLine [LineChunk \"(True,8,\\\"00100000\\\")\"]]" (DocTest.asPrint( test (2^4::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:465" "[ExpectedLine [LineChunk \"(True,144,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (-(2^120)::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:468" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100\\\")\"]]" (DocTest.asPrint( test (2^120::Integer) )), DocTest.test "src/Flat/Instances/Base.hs:479" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:482" "[ExpectedLine [LineChunk \"(True,8,\\\"11111110\\\")\"]]" (DocTest.asPrint( test (127::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:485" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (-128::Int8) )), DocTest.test "src/Flat/Instances/Base.hs:496" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:499" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:502" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:505" "[ExpectedLine [LineChunk \"(True,24,\\\"11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (minBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:510" "[ExpectedLine [LineChunk \"(True,24,\\\"11111110 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (maxBound::Int16) )), DocTest.test "src/Flat/Instances/Base.hs:523" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:526" "[ExpectedLine [LineChunk \"(True,40,\\\"11111111 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (minBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:529" "[ExpectedLine [LineChunk \"(True,40,\\\"11111110 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (maxBound::Int32) )), DocTest.test "src/Flat/Instances/Base.hs:540" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:543" "[ExpectedLine [LineChunk \"(True,80,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (minBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:546" "[ExpectedLine [LineChunk \"(True,80,\\\"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (maxBound::Int64) )), DocTest.test "src/Flat/Instances/Base.hs:565" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000000\\\")\"]]" (DocTest.asPrint( test (0::Float) )), DocTest.test "src/Flat/Instances/Base.hs:568" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000001\\\")\"]]" (DocTest.asPrint( test (1.4012984643E-45::Float) )), DocTest.test "src/Flat/Instances/Base.hs:571" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 01111111 11111111 11111111\\\")\"]]" (DocTest.asPrint( test (1.1754942107E-38::Float) )), DocTest.test "src/Flat/Instances/Base.hs:598" "[ExpectedLine [LineChunk \"(True,16,\\\"00000100 00000010\\\")\"]]" (DocTest.asPrint( test (4 :+ 2 :: Complex Word8) )), DocTest.test "src/Flat/Instances/Base.hs:606" "[ExpectedLine [LineChunk \"(True,16,\\\"00000011 00000100\\\")\"]]" (DocTest.asPrint( test (3%4::Ratio Word8) )), DocTest.test "src/Flat/Instances/Base.hs:618" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test ([]::[Bool]) )), DocTest.test "src/Flat/Instances/Base.hs:621" "[ExpectedLine [LineChunk \"(True,5,\\\"10100\\\")\"]]" (DocTest.asPrint( test [False,False] )), DocTest.test "src/Flat/Instances/Base.hs:655" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (B.fromList [True]) )), DocTest.test "src/Flat/Instances/Base.hs:658" "[ExpectedLine [LineChunk \"(True,4,\\\"0100\\\")\"]]" (DocTest.asPrint( test (B.fromList [False,False]) )), DocTest.test "src/Flat/Instances/Base.hs:668" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (False,()) )), DocTest.test "src/Flat/Instances/Base.hs:671" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test ((),()) )), DocTest.test "src/Flat/Instances/Base.hs:676" "[ExpectedLine [LineChunk \"(True,7,\\\"0111011\\\")\"]]" (DocTest.asPrint( test (False,True,True,True,False,True,True) ))]
+ test/DocTest/Flat/Instances/ByteString.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.ByteString where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.ByteString+import Flat.Instances.Test+import Flat.Instances.Base+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS++tests :: IO TestTree+tests = testGroup "Flat.Instances.ByteString" <$> sequence [ DocTest.test "src/Flat/Instances/ByteString.hs:39" "[ExpectedLine [LineChunk \"(True,48,[1,3,11,22,33,0])\"]]" (DocTest.asPrint( tst (B.pack [11,22,33]) )), DocTest.test "src/Flat/Instances/ByteString.hs:52" "[ExpectedLine [LineChunk \"(True,16,[1,0])\"]]" (DocTest.asPrint( tst (B.pack []) )), DocTest.test "src/Flat/Instances/ByteString.hs:57" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,B.pack [11,22,33])) )), DocTest.test "src/Flat/Instances/ByteString.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (tst (B.pack [55]) ==) [tst (L.pack [55]),tst (SBS.pack [55])] )), DocTest.test "src/Flat/Instances/ByteString.hs:71" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,L.pack [11,22,33])) )), DocTest.test "src/Flat/Instances/ByteString.hs:80" "[ExpectedLine [LineChunk \"(True,51,[65,3,11,22,33,0])\"]]" (DocTest.asPrint( tst ((False,True,False,SBS.pack [11,22,33])) ))]
+ test/DocTest/Flat/Instances/Containers.hs view
@@ -0,0 +1,16 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Containers where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Containers+import Flat.Instances.Test+import Data.Set+import Data.Sequence+import Data.IntMap+import Data.Map+import Data.Tree+import Flat.Instances.Mono++tests :: IO TestTree+tests = testGroup "Flat.Instances.Containers" <$> sequence [ DocTest.test "src/Flat/Instances/Containers.hs:45" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (Data.IntMap.empty :: IntMap ()) )), DocTest.test "src/Flat/Instances/Containers.hs:48" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.IntMap.fromList [(1,"a"),(2,"b")] )), DocTest.test "src/Flat/Instances/Containers.hs:59" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (Data.Map.empty :: Map () ()) )), DocTest.test "src/Flat/Instances/Containers.hs:62" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Map.fromList [("a","aa"),("b","bb")] )), DocTest.test "src/Flat/Instances/Containers.hs:67" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [("a","aa"),("b","bb")] in tst (Data.Map.fromList l) == tst (Data.Map.fromList $ Prelude.reverse l) )), DocTest.test "src/Flat/Instances/Containers.hs:72" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [(2::Int,"b"),(1,"a")] in tst (Data.IntMap.fromList l) == tst (Data.Map.fromList l) )), DocTest.test "src/Flat/Instances/Containers.hs:83" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Sequence.fromList [3::Word8,4,7] )), DocTest.test "src/Flat/Instances/Containers.hs:90" "[ExpectedLine [LineChunk \"(True,40,[3,11,22,33,0])\"]]" (DocTest.asPrint( tst $ AsArray (Data.Sequence.fromList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Containers.hs:93" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst $ Data.Sequence.fromList [11::Word8,22,33] )), DocTest.test "src/Flat/Instances/Containers.hs:104" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( asList Data.Set.fromList [3::Word8,4,7] )), DocTest.test "src/Flat/Instances/Containers.hs:113" "[ExpectedLine [LineChunk \"(True,39,[1,129,64,200,32])\"]]" (DocTest.asPrint( tst (Node (1::Word8) [Node 2 [Node 3 []], Node 4 []]) ))]
+ test/DocTest/Flat/Instances/DList.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.DList where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.DList+import Flat.Instances.Test+import Flat.Instances.Base()+import Flat.Run+import Data.DList+test = tstBits++tests :: IO TestTree+tests = testGroup "Flat.Instances.DList" <$> sequence [ DocTest.test "src/Flat/Instances/DList.hs:17" "[ExpectedLine [LineChunk \"(True,19,\\\"10000011 11000001 110\\\")\"]]" (DocTest.asPrint( test (Data.DList.fromList [7::Word,7]) )), DocTest.test "src/Flat/Instances/DList.hs:20" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [7::Word,7] in flat (Data.DList.fromList l) == flat l ))]
+ test/DocTest/Flat/Instances/Extra.hs view
@@ -0,0 +1,10 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Extra where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Extra+import Flat.Instances.Test++tests :: IO TestTree+tests = testGroup "Flat.Instances.Extra" <$> sequence [ DocTest.test "src/Flat/Instances/Extra.hs:13" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( tstBits "" )), DocTest.test "src/Flat/Instances/Extra.hs:16" "[ExpectedLine [LineChunk \"(True,28,\\\"10110000 11011000 01101100 0010\\\")\"]]" (DocTest.asPrint( tstBits "aaa" ))]
+ test/DocTest/Flat/Instances/Mono.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Mono where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Mono+import Flat.Instances.Base()+import Flat.Instances.Test+import Data.Word+import qualified Data.Set+import qualified Data.Map++tests :: IO TestTree+tests = testGroup "Flat.Instances.Mono" <$> sequence [ DocTest.test "src/Flat/Instances/Mono.hs:62" "[ExpectedLine [LineChunk \"\\\"1111110\\\"\"]]" (DocTest.asPrint( flatBits $ AsList [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:69" "[ExpectedLine [LineChunk \"\\\"1111110\\\"\"]]" (DocTest.asPrint( flatBits $ [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:74" "[ExpectedLine [LineChunk \"\\\"00000011 11100000 000\\\"\"]]" (DocTest.asPrint( flatBits $ AsArray [True,True,True] )), DocTest.test "src/Flat/Instances/Mono.hs:79" "[ExpectedLine [LineChunk \"\\\"10000001 11110000 00000\\\"\"]]" (DocTest.asPrint( flatBits $ [AsArray [True,True,True]] )), DocTest.test "src/Flat/Instances/Mono.hs:82" "[ExpectedLine [LineChunk \"\\\"11100000 11111111 11000000 00\\\"\"]]" (DocTest.asPrint( flatBits $ (True,True,True,AsArray $ replicate 7 True) )), DocTest.test "src/Flat/Instances/Mono.hs:85" "[ExpectedLine [LineChunk \"\\\"00000000\\\"\"]]" (DocTest.asPrint( flatBits $ AsArray ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:88" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( flatBits $ AsList ([]::[()]) )), DocTest.test "src/Flat/Instances/Mono.hs:91" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Mono.hs:94" "[ExpectedLine [LineChunk \"(True,28,[133,197,164,32])\"]]" (DocTest.asPrint( tst (AsSet (Data.Set.fromList [11::Word8,22,33])) )), DocTest.test "src/Flat/Instances/Mono.hs:97" "[ExpectedLine [LineChunk \"(True,99,[129,129,2,3,0,65,66,2,131,3,132,0,0])\"]]" (DocTest.asPrint( tst [AsArray [1..3], AsArray [4..8]] )), DocTest.test "src/Flat/Instances/Mono.hs:100" "[ExpectedLine [LineChunk \"(True,99,[129,128,129,1,128,65,65,1,65,129,194,0,0])\"]]" (DocTest.asPrint( tst $ [AsArray [(1::Word8)..3], AsArray [4..8]] )), DocTest.test "src/Flat/Instances/Mono.hs:103" "[ExpectedLine [LineChunk \"(True,42,[129,129,2,3,0,0])\"]]" (DocTest.asPrint( tst $ [AsArray [(1::Int)..3]] )), DocTest.test "src/Flat/Instances/Mono.hs:196" "[ExpectedLine [LineChunk \"(True,1,[0])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList ([]::[(Word8,())]))) )), DocTest.test "src/Flat/Instances/Mono.hs:199" "[ExpectedLine [LineChunk \"(True,18,[129,132,128])\"]]" (DocTest.asPrint( tst (AsMap (Data.Map.fromList [(3::Word,9::Word)])) ))]
+ test/DocTest/Flat/Instances/Text.hs view
@@ -0,0 +1,15 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Text where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Text+import Flat.Instances.Base()+import Flat.Instances.Test+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Word+tt t = let (ts,_,bs) = tst t in (ts,bs)++tests :: IO TestTree+tests = testGroup "Flat.Instances.Text" <$> sequence [ DocTest.test "src/Flat/Instances/Text.hs:26" "[ExpectedLine [LineChunk \"(True,[1,0])\"]]" (DocTest.asPrint( tt $ T.pack "" )), DocTest.test "src/Flat/Instances/Text.hs:29" "[ExpectedLine [LineChunk \"(True,[1,3,97,97,97,0])\"]]" (DocTest.asPrint( tt $ T.pack "aaa" )), DocTest.test "src/Flat/Instances/Text.hs:32" "[ExpectedLine [LineChunk \"(True,[1,6,194,162,194,162,194,162,0])\"]]" (DocTest.asPrint( tt $ T.pack "¢¢¢" )), DocTest.test "src/Flat/Instances/Text.hs:35" "[ExpectedLine [LineChunk \"(True,[1,9,230,151,165,230,151,165,230,151,165,0])\"]]" (DocTest.asPrint( tt $ T.pack "日日日" )), DocTest.test "src/Flat/Instances/Text.hs:39" "[ExpectedLine [LineChunk \"(True,[1,12,240,144,141,136,240,144,141,136,240,144,141,136,0])\"]]" (DocTest.asPrint( tt $ T.pack "𐍈𐍈𐍈" )), DocTest.test "src/Flat/Instances/Text.hs:45" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( tst (T.pack "abc") == tst (TL.pack "abc") )), DocTest.test "src/Flat/Instances/Text.hs:63" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( tst (UTF8Text $ T.pack "日日日") == tst (T.pack "日日日") )), DocTest.test "src/Flat/Instances/Text.hs:76" "[ExpectedLine [LineChunk \"(True,[1,6,97,0,97,0,97,0,0])\"]]" (DocTest.asPrint( tt (UTF16Text $ T.pack "aaa") )), DocTest.test "src/Flat/Instances/Text.hs:79" "[ExpectedLine [LineChunk \"(True,[1,12,0,216,72,223,0,216,72,223,0,216,72,223,0])\"]]" (DocTest.asPrint( tt (UTF16Text $ T.pack "𐍈𐍈𐍈") ))]
+ test/DocTest/Flat/Instances/Unordered.hs view
@@ -0,0 +1,16 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Unordered where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Unordered+import Flat.Instances.Base()+import Flat.Instances.Test+import Data.Word+import qualified Data.HashMap.Strict+import qualified Data.HashMap.Lazy+import qualified Data.HashSet+test = tstBits++tests :: IO TestTree+tests = testGroup "Flat.Instances.Unordered" <$> sequence [ DocTest.test "src/Flat/Instances/Unordered.hs:21" "[ExpectedLine [LineChunk \"(True,28,\\\"10000000 11000000 10100000 0110\\\")\"]]" (DocTest.asPrint( test (Data.HashSet.fromList [1..3::Word]) )), DocTest.test "src/Flat/Instances/Unordered.hs:31" "[ExpectedLine [LineChunk \"(True,35,\\\"10000001 00001011 01000001 00001011 000\\\")\"]]" (DocTest.asPrint( test (Data.HashMap.Strict.fromList [(1,11),(2,22)]) )), DocTest.test "src/Flat/Instances/Unordered.hs:34" "[ExpectedLine [LineChunk \"(True,35,\\\"10000001 00001011 01000001 00001011 000\\\")\"]]" (DocTest.asPrint( test (Data.HashMap.Lazy.fromList [(1,11),(2,22)]) ))]
+ test/DocTest/Flat/Instances/Vector.hs view
@@ -0,0 +1,14 @@++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Instances.Vector where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Instances.Vector+import Flat.Instances.Test+import Flat.Instances.Base()+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as S++tests :: IO TestTree+tests = testGroup "Flat.Instances.Vector" <$> sequence [ DocTest.test "src/Flat/Instances/Vector.hs:23" "[ExpectedLine [LineChunk \"(True,40,[3,11,22,33,0])\"]]" (DocTest.asPrint( tst (V.fromList [11::Word8,22,33]) )), DocTest.test "src/Flat/Instances/Vector.hs:28" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let l = [11::Word8,22,33] in all (tst (V.fromList l) ==) [tst (U.fromList l),tst (S.fromList l)] ))]
+ test/DocTest/Flat/Tutorial.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveGeneric,DeriveAnyClass#-}++{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}+module DocTest.Flat.Tutorial where+import qualified DocTest+import Test.Tasty(TestTree,testGroup)+import Flat.Tutorial+import Flat+import Flat.Instances.Test (flatBits,allBits)+data Result = Bad | Good deriving (Show,Generic,Flat)+data Direction = North | South | Center | East | West deriving (Show,Generic,Flat)+data List a = Nil | Cons a (List a) deriving (Show,Generic,Flat)++tests :: IO TestTree+tests = testGroup "Flat.Tutorial" <$> sequence [ DocTest.test "src/Flat/Tutorial.hs:41" "[ExpectedLine [LineChunk \"\\\"\\\\149\\\"\"]]" (DocTest.asPrint( flat $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:48" "[ExpectedLine [LineChunk \"Right (Cons North (Cons South Nil))\"]]" (DocTest.asPrint( unflat . flat $ Cons North (Cons South Nil) :: Decoded (List Direction) )), DocTest.test "src/Flat/Tutorial.hs:61" "[ExpectedLine [LineChunk \"\\\"1\\\"\"]]" (DocTest.asPrint( flatBits Good )), DocTest.test "src/Flat/Tutorial.hs:64" "[ExpectedLine [LineChunk \"\\\"0\\\"\"]]" (DocTest.asPrint( flatBits (Nil::List Direction) )), DocTest.test "src/Flat/Tutorial.hs:69" "[ExpectedLine [LineChunk \"\\\"01\\\"\"]]" (DocTest.asPrint( flatBits South )), DocTest.test "src/Flat/Tutorial.hs:72" "[ExpectedLine [LineChunk \"\\\"111\\\"\"]]" (DocTest.asPrint( flatBits West )), DocTest.test "src/Flat/Tutorial.hs:83" "[ExpectedLine [LineChunk \"\\\"1001010\\\"\"]]" (DocTest.asPrint( flatBits $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:88" "[ExpectedLine [LineChunk \"\\\"10010101\\\"\"]]" (DocTest.asPrint( allBits $ Cons North (Cons South Nil) )), DocTest.test "src/Flat/Tutorial.hs:101" "[ExpectedLine [LineChunk \"\\\"11\\\"\"]]" (DocTest.asPrint( flatBits $ Just True ))]
+ test/DocTests.hs view
@@ -0,0 +1,6 @@+module Main where+import Test.Tasty+import Test.Tasty.HUnit+import qualified DocTest.Flat.AsBin++main = (testGroup "DocTests" <$> sequence [DocTest.Flat.AsBin.tests]) >>= defaultMain
test/Spec.hs view
@@ -12,612 +12,788 @@ import Control.Monad import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Short as SBS-import Data.Char-import Data.Either-import Data.Flat-import Data.Flat.Bits-import Data.Flat.Decoder-import qualified Data.Flat.Encoder as E-import qualified Data.Flat.Encoder.Prim as E-import qualified Data.Flat.Encoder.Strict as E-import Data.Int-import Data.List-import qualified Data.Map as M-import Data.Ord-import Data.Proxy-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import Data.Word-import Numeric.Natural-import System.Exit-import Test.Data-import Test.Data.Arbitrary-import Test.Data.Flat-import Test.Data.Values hiding (lbs, ns)-import Test.E-import Test.E.Arbitrary-import Test.E.Flat-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck as QC hiding (getSize)--- import System.Arch-import Data.Flat.Endian-import Data.FloatCast---- instance Flat [Int16]--- instance Flat [Word8]--- instance Flat [Bool]--main = do--- #ifdef ghcjs_HOST_OS--- print "GHCJS"--- #endif-- -- printInfo-- mainTest- -- print $ flatRaw 18446744073709551615::Word64- -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64)- -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1)- -- mainShow- -- eWord64E id 0b---- printInfo = do--- print $ "BigEndian: " ++ show isBigEndian--- print getSystemArch--- print getSystemEndianness--mainShow = do- mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10]- exitFailure--mainTest = defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [- testPrimitives-- ,testEncDec-- ,testFlat- ]--testPrimitives = testGroup "conversion/memory primitives" [- testEndian- ,testFloatingConvert- --,testShifts- ]--testEncDec = testGroup "encode/decode primitives" [- testEncodingPrim- ,testDecodingPrim-#ifdef TEST_DECBITS - ,testDecBits-#endif - ]--testFlat = testGroup "flat/unflat" [- testSize- ,testLargeEnum- ,testContainers- ,flatTests- ,flatUnflatRT- ]----- Data.Flat.Endian tests (to run, need to modify imports and cabal file)-testEndian = testGroup "Endian" [- conv toBE16 (2^10 + 3) (2^9+2^8+4)- ,conv toBE32 (2^18 + 3) 50332672- ,conv toBE64 (2^34 + 3) 216172782180892672- ,conv toBE16 0x1234 0x3412- ,conv toBE32 0x11223344 0x44332211- ,conv toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301- ]--testFloatingConvert = testGroup "Floating conversions" [- conv floatToWord -0.15625 3189768192- ,conv wordToFloat 3189768192 -0.15625- ,conv doubleToWord -0.15625 13818169556679524352- ,conv wordToDouble 13818169556679524352 -0.15625- ,rt "floatToWord" (prop_float_conv :: RT Float)- ,rt "doubleToWord" (prop_double_conv :: RT Double)- ]---- ghcjs bug on shiftR 0, see: https://github.com/ghcjs/ghcjs/issues/706-testShifts = testGroup "Shifts" $ map tst [0..33]- where- tst n = testCase ("shiftR " ++ show n) $- let val = 4294967295::Word32- s = val `shift` (-n)- r = val `shiftR` n- in r @?= s---- shR = shiftR--- shR = unsafeShiftR-shR val 0 = val-shR val n = shift val (-n)--testEncodingPrim = testGroup "Encoding Primitives" [- encRawWith 1 E.eTrueF [0b10000001]- ,encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001]-- ,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1]- ,encRawWith 32 (E.eWord32BEF $ 2^18 + 3) [0,4,0,3,1]-- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1]- ,encRawWith 64 (E.eWord64BEF $ 2^34 + 3) [0,0,0,4,0,0,0,3,1]- ,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129]- ,encRawWith 65 (E.eTrueF >=> E.eWord64BEF (2^34 + 3)) [128,0,0,2,0,0,0,1,129]- ,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129]- ,encRawWith 65 (E.eFalseF >=> E.eWord64BEF (2^34 + 3)) [0,0,0,2,0,0,0,1,129]- ]- where- encRawWith sz enc exp = testCase (unwords ["encode raw with size",show sz]) $ flatRawWith sz enc @?= exp---conv f v e = testCase (unwords ["conv",sshow v,showB . flat $ v,"to",sshow e]) $ f v @?= e--testDecodingPrim = testGroup "Decoding Primitives" [- dec ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) [0b10111110,0b10011010] ((),False,True,False)- ,dec ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) [0b11000000- ,0b00000001- ,0b01000000] ((),2^15+2,True,())- ,dec ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) [0b11000000- ,0b00000000- ,0b00000000- ,0b00000001- ,0b01000000] ((),2^31+2,True,())- ,dec dBE64 [0b10000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000010- ] (2^63+2)-- ,dec ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) [0b11000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000000- ,0b00000001- ,0b01000000] ((),2^63+2,True,())-- ]- where- dec decOp v e = testCase (unwords ["decode",sshow v]) $ unflatRawWith decOp (B.pack v) @?= Right e--testDecBits = testGroup "Decode Bits" $ concat [- decBitsN dBEBits8- ,decBitsN dBEBits16- ,decBitsN dBEBits32- ,decBitsN dBEBits64- ]- where- -- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions- decBitsN :: forall a. (Num a,FiniteBits a,Show a,Flat a) => (Int -> Get a) -> [TestTree]- decBitsN dec = let s = finiteBitSize (undefined::a)- in [decBits_ dec val numBitsToTake pre | numBitsToTake <- [0 .. s], val <- [0::a ,1+2^(s - 2)+2^(s - 5) ,fromIntegral $ (2^s::Integer) - 1],pre <- [0,1,7]]-- decBits_ :: forall a. (FiniteBits a,Show a,Flat a) => (Int -> Get a) -> a -> Int -> Int -> TestTree- decBits_ deco val numBitsToTake pre =- -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary- let vs = B.pack . asBytes . fromBools $ replicate pre False ++ toBools (asBits val)- len = B.length vs- sz = finiteBitSize (undefined::a)- dec :: Get a- dec = do- dropBits pre- r <- deco numBitsToTake- dropBits (len*8-numBitsToTake-pre)- return r- -- we expect the first numBitsToTake bits of the value- expectedD@(Right expected) :: Decoded a = Right $ val `shR` (sz - numBitsToTake) -- ghcjs: shiftR fails, see: https://github.com/ghcjs/ghcjs/issues/706- actualD@(Right actual) :: Decoded a = unflatRawWith dec vs- in testCase (unwords ["take",show numBitsToTake,"bits from",show val,"of size",show sz,"with prefix",show pre,"sequence",showB vs,show expected,show actual,show $ val == actual,show $ expected == actual,show $ expected /= actual,show $ show expected == show actual,show $ flat expected == flat actual])- $ actualD @?= expectedD---testSize = testGroup "Size" $ concat [- sz () 0- ,sz True 1- ,sz One 2- ,sz Two 2- ,sz Three 2- ,sz Four 3- ,sz Five 3- ,sz 'a' 8- ,sz 'à' 16- ,sz '经' 24- ,sz (0::Word8) 8- ,sz (1::Word8) 8- ,concatMap (uncurry sz) ns- ,concatMap (uncurry sz) nsI- ,concatMap (uncurry sz) nsII- ,sz (1.1::Float) 32- ,sz (1.1::Double) 64- ,sz "" 1- ,sz "abc" (4+3*8)- ,sz ((),(),Unit) 0- ,sz (True,False,One,Five) 7- ,sz map1 7- ,sz bs (4+3*8)- ,sz stBS bsSize- ,sz lzBS bsSize-#ifndef ghcjs_HOST_OS- ,sz shBS bsSize-#endif- ,sz tx utf8Size- ,sz (UTF8Text tx) utf8Size- ,sz (UTF16Text tx) utf16Size- ]- where- tx = T.pack "txt"- utf8Size = 8+8+3*32+8- utf16Size = 8+8+3*16+8- bsSize = 8+8+3*8+8--sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e]---- E258_256 = 11111110 _257 = 111111110 _258 = 111111111-testLargeEnum = testGroup "test enum with more than 256 constructors" $ concat- [-#ifdef ENUM_LARGE- sz E258_256 8- , sz E258_257 9- , sz E258_258 9-- -- As encode are inlined, this is going to take for ever if this is compiled with -O1 or -O2- -- , encRaw (E258_256) [0b11111110]- -- , encRaw (E258_257) [0b11111111,0b00000000]- -- , encRaw (E258_258) [0b11111111,0b10000000]- -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000]-- , map trip [E258_1,E258_256,E258_257,E258_258]- , map trip [E256_1,E256_134,E256_256]-#endif- ]--testContainers = testGroup "containers" [- trip longSeq- , trip dataMap- , trip listMap- -- , trip intMap- ]--flatUnflatRT = testGroup "unflat (flat v) == v"- [ rt "()" (prop_Flat_roundtrip:: RT ())- ,rt "Bool" (prop_Flat_roundtrip::RT Bool)- ,rt "Word8" (prop_Flat_Large_roundtrip:: RTL Word8)- ,rt "Word16" (prop_Flat_Large_roundtrip:: RTL Word16)- ,rt "Word32" (prop_Flat_Large_roundtrip:: RTL Word32)- ,rt "Word64" (prop_Flat_Large_roundtrip:: RTL Word64)- ,rt "Word" (prop_Flat_Large_roundtrip:: RTL Word)- ,rt "Int8" (prop_Flat_Large_roundtrip:: RTL Int8)- ,rt "Int16" (prop_Flat_Large_roundtrip:: RTL Int16)- ,rt "Int32" (prop_Flat_Large_roundtrip:: RTL Int32)- ,rt "Int64" (prop_Flat_Large_roundtrip:: RTL Int64)- ,rt "Int" (prop_Flat_Large_roundtrip:: RTL Int)- ,rt "Integer" (prop_Flat_roundtrip:: RT Integer)- ,rt "Natural" (prop_Flat_roundtrip:: RT Natural)- ,rt "Float" (prop_Flat_roundtrip:: RT Float)- ,rt "Double" (prop_Flat_roundtrip:: RT Double)- ,rt "Char" (prop_Flat_roundtrip:: RT Char)- --,rt "ASCII" (prop_Flat_roundtrip:: RT ASCII)- ,rt "Unit" (prop_Flat_roundtrip:: RT Unit)- ,rt "Un" (prop_Flat_roundtrip:: RT Un )- ,rt "N" (prop_Flat_roundtrip:: RT N )- ,rt "E2" (prop_Flat_roundtrip:: RT E2 )- ,rt "E3" (prop_Flat_roundtrip:: RT E3 )- ,rt "E4" (prop_Flat_roundtrip:: RT E4 )- ,rt "E8" (prop_Flat_roundtrip:: RT E8 )- ,rt "E16" (prop_Flat_roundtrip:: RT E16 )- ,rt "E17" (prop_Flat_roundtrip:: RT E17 )- ,rt "E32" (prop_Flat_roundtrip:: RT E32 )- ,rt "A" (prop_Flat_roundtrip:: RT A )- ,rt "B" (prop_Flat_roundtrip:: RT B )- ,rt "Maybe N" (prop_Flat_roundtrip:: RT (Maybe N))- ,rt "Either N Bool" (prop_Flat_roundtrip:: RT (Either N Bool))- ,rt "Either Int Char" (prop_Flat_roundtrip:: RT (Either Int Char))- -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))- -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))- ,rt "List N" (prop_Flat_roundtrip:: RT (List N))- ,rt "[Int16]" (prop_Flat_roundtrip:: RT [Int16])- ,rt "String" (prop_Flat_roundtrip:: RT String)- -- Generates incorrect ascii chars?- ,rt "Text" (prop_Flat_roundtrip:: RT T.Text)- ,rt "ByteString" (prop_Flat_roundtrip:: RT B.ByteString)- ,rt "Lazy ByteString" (prop_Flat_roundtrip:: RT L.ByteString)-#ifndef ghcjs_HOST_OS- ,rt "Short ByteString" (prop_Flat_roundtrip:: RT SBS.ShortByteString)-#endif- ]--rt n = QC.testProperty (unwords ["round trip",n])--flatTests = testGroup "flat/unflat Unit tests" $ concat [-- -- Expected errors- errDec (Proxy::Proxy Bool) [] -- no data- ,errDec (Proxy::Proxy Bool) [128] -- no filler- ,errDec (Proxy::Proxy Bool) [128+1,1,2,4,8] -- additional bytes-- ,encRaw () []- ,encRaw ((),(),Unit) []- ,encRaw (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97]- ,a () [1]- ,a True [128+1]- ,a (True,True) [128+64+1]- ,a (True,False,True) [128+32+1]- ,a (True,False,True,True) [128+32+16+1]- ,a (True,False,True,True,True) [128+32+16+8+1]- ,a (True,False,True,True,True,True) [128+32+16+8+4+1]- ,a (True,False,True,True,True,True,True) [128+32+16+8+4+2+1]- ,a (True,False,True,True,(True,True,True,True)) [128+32+16+8+4+2+1,1]- ,encRaw (True,False,True,True) [128+32+16]- ,encRaw ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32]- ,encRaw ('\0','\1','\127') [0,1,127]- ,encRaw (33::Word32,44::Word32) [33,44]- --,s (Elem True) [64]- --,s (NECons True (NECons False (Elem True))) [128+64+32+4]- ,encRaw (0::Word8) [0]- ,encRaw (1::Word8) [1]- ,encRaw (255::Word8) [255]- ,encRaw (0::Word16) [0]- ,encRaw (1::Word16) [1]- ,encRaw (255::Word16) [255,1]- ,encRaw (256::Word16) [128,2]- ,encRaw (65535::Word16) [255,255,3]- ,encRaw (127::Word32) [127]- ,encRaw (128::Word32) [128,1]- ,encRaw (129::Word32) [129,1]- ,encRaw (255::Word32) [255,1]- ,encRaw (16383::Word32) [255,127]- ,encRaw (16384::Word32) [128,128,1]- ,encRaw (16385::Word32) [129,128,1]- ,encRaw (32767::Word32) [255,255,1]- ,encRaw (32768::Word32) [128,128,2]- ,encRaw (32769::Word32) [129,128,2]- ,encRaw (65535::Word32) [255,255,3]- ,encRaw (2097151::Word32) [255,255,127]- ,encRaw (2097152::Word32) [128,128,128,1]- ,encRaw (2097153::Word32) [129,128,128,1]- ,encRaw (4294967295::Word32) [255,255,255,255,15]- ,encRaw (255::Word64) [255,1]- ,encRaw (65535::Word64) [255,255,3]- ,encRaw (4294967295::Word64) [255,255,255,255,15]- ,encRaw (18446744073709551615::Word64) [255,255,255,255,255,255,255,255,255,1]- ,encRaw (False,18446744073709551615::Word64) [127,255,255,255,255,255,255,255,255,128,128]- ,encRaw (255::Word) [255,1]- ,encRaw (65535::Word) [255,255,3]- ,encRaw (4294967295::Word) [255,255,255,255,15]- ,tstI [0::Int8,2,-2]- ,encRaw (127::Int8) [254]- ,encRaw (-128::Int8) [255]- ,tstI [0::Int16,2,-2,127,-128]- ,tstI [0::Int32,2,-2,127,-128]- ,tstI [0::Int64,2,-2,127,-128]- ,encRaw (-1024::Int64) [255,15]- ,encRaw (maxBound::Word8) [255]- ,encRaw (True,maxBound::Word8) [255,128]- ,encRaw (maxBound::Word16) [255,255,3]- ,encRaw (True,maxBound::Word16) [255,255,129,128]- ,encRaw (maxBound::Word32) [255,255,255,255,15]- ,encRaw (True,maxBound::Word32) [255,255,255,255,135,128]- ,encRaw (maxBound::Word64) [255,255,255,255,255,255,255,255,255,1]- ,encRaw (True,maxBound::Word64) [255,255,255,255,255,255,255,255,255,128,128]- ,encRaw (minBound::Int64) [255,255,255,255,255,255,255,255,255,1]- ,encRaw (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1]- ,tstI [0::Int,2,-2,127,-128]- ,tstI [0::Integer,2,-2,127,-128,-256,-512]- ,encRaw (-1024::Integer) [255,15]- ,encRaw (0::Float) [0,0,0,0]- ,encRaw (-2::Float) [0b11000000,0,0,0]- ,encRaw (0.085::Float) [0b00111101,0b10101110,0b00010100,0b01111011]- ,encRaw (0::Double) [0,0,0,0,0,0,0,0]- ,encRaw (-2::Double) [0b11000000,0,0,0,0,0,0,0]- ,encRaw (23::Double) [0b01000000,0b00110111,0,0,0,0,0,0]- ,encRaw (-0.15625::Float) [0b10111110,0b00100000,0,0]- ,encRaw (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0]- ,encRaw (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010]- ,encRaw (Left True :: Either Bool (Double, Double)) [0b01000000]- ,encRaw (-2.1234E15 :: Double) [195,30,44,226,90,221,64,0]- ,encRaw (1.1234E-22 :: Double) [59,96,249,241,120,219,249,174]- ,encRaw ((False,-2.1234E15) :: (Bool,Double)) [97,143,22,113,45,110,160,0,0]- ,encRaw ((True,-2.1234E15) :: (Bool,Double)) [225,143,22,113,45,110,160,0,0]- ,encRaw ((-2.1234E15 , 1.1234E-22) :: (Double, Double)) $ [0b11000011,30,44,226,90,221,64,0] ++ [59,96,249,241,120,219,249,174]- ,encRaw ((True,-2.1234E15 , 1.1234E-22) :: (Bool,Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0]- ,encRaw (Right (-2.1234E15 , 1.1234E-22) :: Either Bool (Double, Double)) [0b11100001,143,22,113,45,110,160,0,29,176,124,248,188,109,252,215,0]- ,encRaw (Left True:: Either Bool Direction) [0b01000000]- ,encRaw (Right West :: Either Bool Direction) [0b11110000]---- ,map trip [minBound,maxBound::Word8]- ,map trip [minBound,maxBound::Word16]- ,map trip [minBound,maxBound::Word32]- ,map trip [minBound,maxBound::Word64]- ,map trip [minBound::Int8,maxBound::Int8]- ,map trip [minBound::Int16,maxBound::Int16]- ,map trip [minBound::Int32,maxBound::Int32]- ,map trip [minBound::Int64,maxBound::Int64]- ,map trip [0::Float,-0::Float,0/0::Float,1/0::Float]- ,map trip [0::Double,-0::Double,0/0::Double,1/0::Double]- ,encRaw '\0' [0]- ,encRaw '\1' [1]- ,encRaw '\127' [127]- ,encRaw 'a' [97]- ,encRaw 'à' [224,1]- ,encRaw '经' [207,253,1]- ,[trip [chr 0x10FFFF]]- ,encRaw Unit []- ,encRaw (Un False) [0]- ,encRaw (One,Two,Three) [16+8]- ,encRaw (Five,Five,Five) [255,128]- --,s (NECons True (Elem True)) [128+64+16]- ,encRaw "" [0]-#ifdef LIST_BIT- ,encRaw "abc" [176,216,172,96]- ,encRaw [False,True,False,True] [128- +32+16- +8- +2+1,0]-#elif defined(LIST_BYTE)- ,s "abc" s3- ,s (cs 600) s600-#endif- -- Aligned structures- --,s (T.pack "") [1,0]- --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]- --,s (T.pack "abc") (al s3)- --,s (T.pack $ cs 600) (al s600)- ,encRaw map1 [0b10111000]- ,encRaw (B.pack $ csb 3) (bsl c3)- ,encRaw (B.pack $ csb 600) (bsl s600)- ,encRaw (L.pack $ csb 3) (bsl c3)- -- Long LazyStrings can have internal sections shorter than 255- --,s (L.pack $ csb 600) (bsl s600)- ,[trip [1..100::Int16]]- ,[trip asciiStrT,trip "维护和平正",trip (T.pack "abc"),trip unicodeText,trip unicodeTextUTF8T]- ,[trip longBS,trip longLBS]-#ifndef ghcjs_HOST_OS- ,[trip longSBS]- ,[trip unicodeTextUTF16T]-#endif- ]- where-- --al = (1:) -- prealign- bsl = id -- noalign-- tstI = map ti-- ti v | v >= 0 = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral v ::Word64)- | otherwise = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral (-v) - 1 ::Word64)-- teq a b = ser a @?= ser b-- --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]-- -- Aligned values unflat to the original value, modulo the added filler.- a v e = [testCase (unwords ["flat",sshow v]) $ ser v @?= e- ,testCase (unwords ["unflat",sshow v]) $ let Right v' = des e in v @?= v']- -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e- -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']---encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree]-encRaw v e = [testCase (unwords ["flat raw",sshow v,show . B.unpack . flat $ v]) $ serRaw v @?= e]--trip :: forall a .(Show a,Flat a) => a -> TestTree-trip v = testCase (unwords ["roundtrip",sshow v]) $- -- we use show to get Right NaN == Right NaN- show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a)---- Test Data-lzBS = L.pack bs-stBS = B.pack bs-bs = [32,32,32::Word8]-s3 = [3,97,98,99,0]-c3a = [3,99,99,99,0] -- Array Word8-c3 = pre c3a-s600 = pre s600a-pre = (1:)-s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]]-s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]]-longSeq :: Seq.Seq Word8-longSeq = Seq.fromList lbs-longBS = B.pack lbs-longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]-lbs = concat $ replicate 100 [234,123,255,0]-cs n = replicate n 'c' -- take n $ cycle ['a'..'z']-csb = map (fromIntegral . ord) . cs-map1 = M.fromList [(False,True),(True,False)]--ns :: [(Word64, Int)]-ns = [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]--nsI :: [(Int64, Int)]-nsI = nsI_-nsII :: [(Integer, Int)]-nsII = nsI_-nsI_ = [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]----#ifndef ghcjs_HOST_OS-shBS = SBS.toShort stBS-longSBS = SBS.toShort longBS-#endif--sshow = take 80 . show--showB = show . B.unpack--errDec :: forall a . (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree]---errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""]-errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in isRight ev @?= False]--ser :: Flat a => a -> [Word8]-ser = B.unpack . flat--des :: Flat a => [Word8] -> Decoded a-des = unflat--flatRawWith sz enc = B.unpack $ E.strictEncoder (sz+8) (E.Encoding $ enc >=> E.eFillerF)--serRaw :: Flat a => a -> [Word8]--- serRaw = B.unpack . flatRaw--- serRaw = L.unpack . flatRaw-serRaw = asBytes . bits----desRaw :: Flat a => [Word8] -> Decoded a---desRaw = unflatRaw . L.pack--type RT a = a -> Bool-type RTL a = Large a -> Bool--prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool-prop_Flat_roundtrip = roundTripExt--prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool-prop_Flat_Large_roundtrip (Large x) = roundTripExt x--roundTrip x = unflat (flat x::B.ByteString) == Right x---- Test roundtrip for both the value and the value embedded between bools-roundTripExt x = roundTrip x && roundTrip (True,x,False)--prop_double_conv d = wordToDouble (doubleToWord d) == d--prop_float_conv d = wordToFloat (floatToWord d) == d--{--prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool-prop_common_unsigned n _ = let n2 :: h = fromIntegral n- in flat n == flat n2--}---- e :: Stream Bool--- e = unflatIncremental . flat $ stream1---- el :: List Bool--- el = unflatIncremental . flat $ infList---- deflat = unflat---- b1 :: BLOB UTF8--- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))--- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))-+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as SBS+import Data.Char+import Data.Either+import Data.FloatCast+import Data.Int+import Data.Proxy+import qualified Data.Sequence as Seq+import Data.String (fromString)+import qualified Data.Text as T+import Data.Text.Arbitrary+import Data.Word+import Flat+import Flat.Bits+import Flat.Decoder+import qualified Flat.Encoder as E+import qualified Flat.Encoder.Prim as E+import qualified Flat.Encoder.Strict as E+import Flat.Endian+import Numeric.Natural+import System.Exit+import Test.Data+import Test.Data.Arbitrary ()+import Test.Data.Flat+import Test.Data.Values hiding (lbs, ns)+import Test.E+import Test.E.Arbitrary ()+import Test.E.Flat+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC hiding (getSize)+-- import Test.QuickCheck.Arbitrary+import qualified Data.Complex as B+import qualified Data.IntMap.Lazy as CL+import qualified Data.IntMap.Strict as CS+import qualified Data.Map as C+import qualified Data.Map.Lazy as CL+import qualified Data.Map.Strict as CS+import qualified Data.Ratio as B+-- import Data.List+-- import Data.Ord+#if MIN_VERSION_base(4,9,0)+import qualified Data.List.NonEmpty as BI+#endif++instance Arbitrary UTF8Text where+ arbitrary = UTF8Text <$> arbitrary++ shrink t = UTF8Text <$> shrink (unUTF8 t)++#if! defined (ETA_VERSION)+instance Arbitrary UTF16Text where+ arbitrary = UTF16Text <$> arbitrary++ shrink t = UTF16Text <$> shrink (unUTF16 t)+#endif++-- instance Flat [Int16]+-- instance Flat [Word8]+-- instance Flat [Bool]+main = do+ -- printInfo+ -- print $ flat asciiStrT+ mainTest++ -- print $ flatRaw 18446744073709551615::Word64+ -- print $ B.unpack . flat $ (True,0::Word64,18446744073709551615::Word64)+ -- print (2^56::Word64,fromIntegral (1::Word8) `shiftL` 56 :: Word64,(18446744073709551615::Word64) `shiftR` 1)+ -- mainShow+ -- eWord64E id 0b+mainShow = do+ mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1 .. 10]+ exitFailure++mainTest = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [testPrimitives, testEncDec, testFlat]++testPrimitives =+ testGroup "conversion/memory primitives" [testEndian, testFloatingConvert,testShifts ]++testEncDec = testGroup+ "encode/decode primitives"+ [ testEncodingPrim+ , testDecodingPrim+#ifdef TEST_DECBITS+ , testDecBits+#endif+ ]++testFlat = testGroup+ "flat/unflat"+ [testSize, testLargeEnum, testContainers, flatUnflatRT, flatTests]++-- Flat.Endian tests (to run, need to modify imports and cabal file)+testEndian = testGroup+ "Endian"+ [ convBE toBE16 (2 ^ 10 + 3) (2 ^ 9 + 2 ^ 8 + 4)+ , convBE toBE32 (2 ^ 18 + 3) 50332672+ , convBE toBE64 (2 ^ 34 + 3) 216172782180892672+ , convBE toBE16 0x1234 0x3412+ , convBE toBE32 0x11223344 0x44332211+ , convBE toBE64 0x0123456789ABCDEF 0xEFCDAB8967452301]++testFloatingConvert = testGroup+ "Floating conversions"+ [ conv floatToWord (-0.15625) 3189768192+ , conv wordToFloat 3189768192 (-0.15625)+ , conv doubleToWord (-0.15625) 13818169556679524352+ , conv wordToDouble 13818169556679524352 (-0.15625)+ , rt "floatToWord" (prop_float_conv :: RT Float)+ , rt "doubleToWord" (prop_double_conv :: RT Double)]++convBE f v littleEndianE =+ let e = if isBigEndian+ then v+ else littleEndianE+ in testCase (unwords ["conv BigEndian", sshow v, "to", sshow e]) $ f v @?= e++conv f v e = testCase+ (unwords ["conv", sshow v, showB . flat $ v, "to", sshow e])+ $ f v @?= e++testShifts = testGroup "Shifts" $ map tst [0 .. 33]+ where+ tst n = testCase ("shiftR " ++ show n)+ $ let val = 4294967295 :: Word32+ s = val `shift` (-n)+ r = val `shiftR` n+ in r @?= s++-- shR = shiftR+-- shR = unsafeShiftR+shR val 0 = val+shR val n = shift val (-n)++testEncodingPrim = testGroup+ "Encoding Primitives"+ [ encRawWith 1 E.eTrueF [0b10000001]+ , encRawWith 3 (E.eTrueF >=> E.eFalseF >=> E.eTrueF) [0b10100001]+ -- Depends on endianess+ --,encRawWith 32 (E.eWord32E id $ 2^18 + 3) [3,0,4,0,1]+ -- ,encRawWith 64 (E.eWord64E id $ 0x1122334455667788) [0x88,0x77,0x66,0x55,0x44,0x33,0x22,0x11,1]+ --,encRawWith 65 (E.eTrueF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,128,129]+ --,encRawWith 65 (E.eFalseF >=> E.eWord64E id (2^34 + 3)) [1,0,0,0,2,0,0,0,129]+ -- Big Endian+ , encRawWith 32 (E.eWord32BEF $ 2 ^ 18 + 3) [0, 4, 0, 3, 1]+ , encRawWith 64 (E.eWord64BEF $ 2 ^ 34 + 3) [0, 0, 0, 4, 0, 0, 0, 3, 1]+ , encRawWith+ 65+ (E.eTrueF >=> E.eWord64BEF (2 ^ 34 + 3))+ [128, 0, 0, 2, 0, 0, 0, 1, 129]+ , encRawWith+ 65+ (E.eFalseF >=> E.eWord64BEF (2 ^ 34 + 3))+ [0, 0, 0, 2, 0, 0, 0, 1, 129]]+ where+ encRawWith sz enc exp = testCase+ (unwords ["encode raw with size", show sz])+ $ flatRawWith sz enc @?= exp++testDecodingPrim = testGroup+ "Decoding Primitives"+ [ dec+ ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool)+ [0b10111110, 0b10011010]+ ((), False, True, False)+ , dec+ ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6)+ [0b11000000, 0b00000001, 0b01000000]+ ((), 2 ^ 15 + 2, True, ())+ , dec+ ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6)+ [0b11000000, 0b00000000, 0b00000000, 0b00000001, 0b01000000]+ ((), 2 ^ 31 + 2, True, ())+ , dec+ dBE64+ [ 0b10000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000010]+ (2 ^ 63 + 2)+ , dec+ ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6)+ [ 0b11000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000000+ , 0b00000001+ , 0b01000000]+ ((), 2 ^ 63 + 2, True, ())]+ where+ dec decOp v e = testCase (unwords ["decode", sshow v])+ $ unflatRawWith decOp (B.pack v) @?= Right e++testDecBits = testGroup "Decode Bits"+ $ concat+ [ decBitsN dBEBits8+ , decBitsN dBEBits16+ , decBitsN dBEBits32+ , decBitsN dBEBits64]+-- Test dBEBits8/16/32/64, extraction of up to 8/16/32/bits from various positions+ where+ decBitsN :: forall a.+ (Num a, FiniteBits a, Show a, Flat a)+ => (Int -> Get a)+ -> [TestTree]+ decBitsN dec = let s = finiteBitSize (undefined :: a)+ in [decBits_ dec val numBitsToTake pre+ | numBitsToTake <- [0 .. s]+ , val <- [ 0 :: a+ , 1 + 2 ^ (s - 2) + 2 ^ (s - 5)+ , fromIntegral $ (2 ^ s :: Integer) - 1]+ , pre <- [0, 1, 7]]++ decBits_ :: forall a.+ (FiniteBits a, Show a, Flat a)+ => (Int -> Get a)+ -> a+ -> Int+ -> Int+ -> TestTree+ decBits_ deco val numBitsToTake pre =+ -- a sequence composed by pre zero bits followed by the val and zero bits till the next byte boundary+ let vs = B.pack . asBytes . fromBools+ $ replicate pre False ++ toBools (asBits val)+ len = B.length vs+ sz = finiteBitSize (undefined :: a)+ dec :: Get a+ dec = do+ dropBits pre+ r <- deco numBitsToTake+ dropBits (len * 8 - numBitsToTake - pre)+ return r+ -- we expect the first numBitsToTake bits of the value+ expectedD@(Right expected) :: Decoded a = Right+ $ val `shR` (sz - numBitsToTake)+ actualD@(Right actual) :: Decoded a = unflatRawWith dec vs+ in testCase+ (unwords+ [ "take"+ , show numBitsToTake+ , "bits from"+ , show val+ , "of size"+ , show sz+ , "with prefix"+ , show pre+ , "sequence"+ , showB vs+ , show expected+ , show actual+ , show $ val == actual+ , show $ expected == actual+ , show $ expected /= actual+ , show $ show expected == show actual+ , show $ flat expected == flat actual])+ $ actualD @?= expectedD++testSize = testGroup "Size"+ $ concat+ [ sz () 0+ , sz True 1+ , sz One 2+ , sz Two 2+ , sz Three 2+ , sz Four 3+ , sz Five 3+ , sz 'a' 8+ , sz 'à' 16+ , sz '经' 24+ , sz (0 :: Word8) 8+ , sz (1 :: Word8) 8+ , concatMap (uncurry sz) ns+ , concatMap (uncurry sz) nsI+ , concatMap (uncurry sz) nsII+ , sz (1.1 :: Float) 32+ , sz (1.1 :: Double) 64+ , sz "" 1+ , sz "abc" (4 + 3 * 8)+ , sz ((), (), Unit) 0+ , sz (True, False, One, Five) 7+ , sz map1 7+ , sz bs (4 + 3 * 8)+ , sz stBS bsSize+ , sz lzBS bsSize+ , sz shBS bsSize+ , sz tx utf8Size+ , sz (UTF8Text tx) utf8Size+#if ! defined (ETA_VERSION)+ , sz (UTF16Text tx) utf16Size+#endif+ ]+ where+ tx = T.pack "txt"++#if MIN_VERSION_text(2,0,0)+ utf8Size = 8 + 8 + (3 * 8) + 8+#else+ utf8Size = 8 + 8 + (3 * 3 * 8) + 8+#endif+ utf16Size = 8 + 8 + 3 * 16 + 8++ bsSize = 8 + 8 + 3 * 8 + 8++sz v e = let calculated = getSize v+ actual = B.length (flat v) * 8 - 1 -- FIX+ in+ [testCase (unwords ["size of", sshow v]) $ calculated @?= e+ -- ,testCase (unwords ["calculated size <= actual", sshow v]) $ actual <= calculated @? unwords ["calculated size",show calculated,"actual",show actual]+ ]++-- E258_256 = 11111110 _257 = 111111110 _258 = 111111111+testLargeEnum = testGroup "test enum with more than 256 constructors"+ $ concat+ [+#ifdef ENUM_LARGE+ sz E258_256 8+ , sz E258_257 9+ , sz E258_258 9+ -- As encodes are inlined, this is going to take for ever if this is compiled with -O1 or -O2+ -- , encRaw (E258_256) [0b11111110]+ -- , encRaw (E258_257) [0b11111111,0b00000000]+ -- , encRaw (E258_258) [0b11111111,0b10000000]+ -- , encRaw (E258_256,E258_257,E258_258) [0b11111110,0b11111111,0b01111111,0b11000000]+ , map trip [E258_1, E258_256, E258_257, E258_258]+ , map trip [E256_1, E256_134, E256_256]+#endif+ ]++testContainers =+ testGroup "containers" [trip longSeq, trip dataMap, trip listMap]++ -- , trip intMap+flatUnflatRT = testGroup+ "unflat (flat v) == v"+ [ rt "()" (prop_Flat_roundtrip :: RT ())+ , rt "Bool" (prop_Flat_roundtrip :: RT Bool)+ , rt "Char" (prop_Flat_roundtrip :: RT Char)+ , rt "Complex" (prop_Flat_roundtrip :: RT (B.Complex Float))+ , rt "Either N Bool" (prop_Flat_roundtrip :: RT (Either N Bool))+ , rt "Either Int Char" (prop_Flat_roundtrip :: RT (Either Int Char))+ , rt "Int8" (prop_Flat_Large_roundtrip :: RTL Int8)+ , rt "Int16" (prop_Flat_Large_roundtrip :: RTL Int16)+ , rt "Int32" (prop_Flat_Large_roundtrip :: RTL Int32)+ , rt "Int64" (prop_Flat_Large_roundtrip :: RTL Int64)+ , rt "Int" (prop_Flat_Large_roundtrip :: RTL Int)+ , rt "[Int16]" (prop_Flat_roundtrip :: RT [Int16])+ , rt "String" (prop_Flat_roundtrip :: RT String)+#if MIN_VERSION_base(4,9,0)+ , rt "NonEmpty" (prop_Flat_roundtrip :: RT (BI.NonEmpty Bool))+#endif+ , rt "Maybe N" (prop_Flat_roundtrip :: RT (Maybe N))+ , rt "Ratio" (prop_Flat_roundtrip :: RT (B.Ratio Int32))+ , rt "Word8" (prop_Flat_Large_roundtrip :: RTL Word8)+ , rt "Word16" (prop_Flat_Large_roundtrip :: RTL Word16)+ , rt "Word32" (prop_Flat_Large_roundtrip :: RTL Word32)+ , rt "Word64" (prop_Flat_Large_roundtrip :: RTL Word64)+ , rt "Word" (prop_Flat_Large_roundtrip :: RTL Word)+ , rt "Natural" (prop_Flat_roundtrip :: RT Natural)+ , rt "Integer" (prop_Flat_roundtrip :: RT Integer)+ , rt "Float" (prop_Flat_roundtrip :: RT Float)+ , rt "Double" (prop_Flat_roundtrip :: RT Double)+ , rt "Text" (prop_Flat_roundtrip :: RT T.Text)+ , rt "UTF8 Text" (prop_Flat_roundtrip :: RT UTF8Text)+#if! defined (ETA_VERSION)+ , rt "UTF16 Text" (prop_Flat_roundtrip :: RT UTF16Text)+#endif+ , rt "ByteString" (prop_Flat_roundtrip :: RT B.ByteString)+ , rt "Lazy ByteString" (prop_Flat_roundtrip :: RT L.ByteString)+ , rt "Short ByteString" (prop_Flat_roundtrip :: RT SBS.ShortByteString)+ , rt "Map.Strict" (prop_Flat_roundtrip :: RT (CS.Map Int Bool))+ , rt "Map.Lazy" (prop_Flat_roundtrip :: RT (CL.Map Int Bool))+ , rt "IntMap.Strict" (prop_Flat_roundtrip :: RT (CS.IntMap Bool))+ , rt "IntMap.Lazy" (prop_Flat_roundtrip :: RT (CL.IntMap Bool))+ , rt "Unit" (prop_Flat_roundtrip :: RT Unit)+ , rt "Un" (prop_Flat_roundtrip :: RT Un)+ , rt "N" (prop_Flat_roundtrip :: RT N)+ , rt "E2" (prop_Flat_roundtrip :: RT E2)+ , rt "E3" (prop_Flat_roundtrip :: RT E3)+ , rt "E4" (prop_Flat_roundtrip :: RT E4)+ , rt "E8" (prop_Flat_roundtrip :: RT E8)+ , rt "E16" (prop_Flat_roundtrip :: RT E16)+ , rt "E17" (prop_Flat_roundtrip :: RT E17)+ , rt "E32" (prop_Flat_roundtrip :: RT E32)+ , rt "A" (prop_Flat_roundtrip :: RT A)+ , rt "B" (prop_Flat_roundtrip :: RT B)+ -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))+ -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))+ , rt "List N" (prop_Flat_roundtrip :: RT (List N))]++rt n = QC.testProperty (unwords ["round trip", n])++flatTests = testGroup "flat/unflat Unit tests"+ $ concat+ [ -- Expected errors+ errDec (Proxy :: Proxy Bool) [] -- no data+ , errDec (Proxy :: Proxy Bool) [128] -- no filler+ , errDec (Proxy :: Proxy Bool) [128 + 1, 1, 2, 4, 8] -- additional bytes+ , errDec (Proxy :: Proxy Text) (B.unpack (flat ((fromString "\x80") :: B.ByteString))) -- invalid UTF-8+ , encRaw () []+ , encRaw ((), (), Unit) []+ , encRaw (Unit, 'a', Unit, 'a', Unit, 'a', Unit) [97, 97, 97]+ , a () [1]+ , a True [128 + 1]+ , a (True, True) [128 + 64 + 1]+ , a (True, False, True) [128 + 32 + 1]+ , a (True, False, True, True) [128 + 32 + 16 + 1]+ , a (True, False, True, True, True) [128 + 32 + 16 + 8 + 1]+ , a (True, False, True, True, True, True) [128 + 32 + 16 + 8 + 4 + 1]+ , a+ (True, False, True, True, True, True, True)+ [128 + 32 + 16 + 8 + 4 + 2 + 1]+ , a+ (True, False, True, True, (True, True, True, True))+ [128 + 32 + 16 + 8 + 4 + 2 + 1, 1]+ , encRaw (True, False, True, True) [128 + 32 + 16]+ , encRaw+ ( (True, True, False, True, False)+ , (False, False, True, False, True, True))+ [128 + 64 + 16 + 1, 64 + 32]+ , encRaw ('\0', '\1', '\127') [0, 1, 127]+ , encRaw (33 :: Word32, 44 :: Word32) [33, 44]+ --,s (Elem True) [64]+ --,s (NECons True (NECons False (Elem True))) [128+64+32+4]+ , encRaw (0 :: Word8) [0]+ , encRaw (1 :: Word8) [1]+ , encRaw (255 :: Word8) [255]+ , encRaw (0 :: Word16) [0]+ , encRaw (1 :: Word16) [1]+ , encRaw (255 :: Word16) [255, 1]+ , encRaw (256 :: Word16) [128, 2]+ , encRaw (65535 :: Word16) [255, 255, 3]+ , encRaw (127 :: Word32) [127]+ , encRaw (128 :: Word32) [128, 1]+ , encRaw (129 :: Word32) [129, 1]+ , encRaw (255 :: Word32) [255, 1]+ , encRaw (16383 :: Word32) [255, 127]+ , encRaw (16384 :: Word32) [128, 128, 1]+ , encRaw (16385 :: Word32) [129, 128, 1]+ , encRaw (32767 :: Word32) [255, 255, 1]+ , encRaw (32768 :: Word32) [128, 128, 2]+ , encRaw (32769 :: Word32) [129, 128, 2]+ , encRaw (65535 :: Word32) [255, 255, 3]+ , encRaw (2097151 :: Word32) [255, 255, 127]+ , encRaw (2097152 :: Word32) [128, 128, 128, 1]+ , encRaw (2097153 :: Word32) [129, 128, 128, 1]+ , encRaw (4294967295 :: Word32) [255, 255, 255, 255, 15]+ , encRaw (255 :: Word64) [255, 1]+ , encRaw (65535 :: Word64) [255, 255, 3]+ , encRaw (4294967295 :: Word64) [255, 255, 255, 255, 15]+ , encRaw+ (18446744073709551615 :: Word64)+ [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]+ , encRaw+ (False, 18446744073709551615 :: Word64)+ [127, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]+ , encRaw (255 :: Word) [255, 1]+ , encRaw (65535 :: Word) [255, 255, 3]+ , encRaw (4294967295 :: Word) [255, 255, 255, 255, 15]+ , tstI [0 :: Int8, 2, -2]+ , encRaw (127 :: Int8) [254]+ , encRaw (-128 :: Int8) [255]+ , tstI [0 :: Int16, 2, -2, 127, -128]+ , tstI [0 :: Int32, 2, -2, 127, -128]+ , tstI [0 :: Int64, 2, -2, 127, -128]+ , encRaw (-1024 :: Int64) [255, 15]+ , encRaw (maxBound :: Word8) [255]+ , encRaw (True, maxBound :: Word8) [255, 128]+ , encRaw (maxBound :: Word16) [255, 255, 3]+ , encRaw (True, maxBound :: Word16) [255, 255, 129, 128]+ , encRaw (maxBound :: Word32) [255, 255, 255, 255, 15]+ , encRaw (True, maxBound :: Word32) [255, 255, 255, 255, 135, 128]+ , encRaw+ (maxBound :: Word64)+ [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]+ , encRaw+ (True, maxBound :: Word64)+ [255, 255, 255, 255, 255, 255, 255, 255, 255, 128, 128]+ , encRaw+ (minBound :: Int64)+ [255, 255, 255, 255, 255, 255, 255, 255, 255, 1]+ , encRaw+ (maxBound :: Int64)+ [254, 255, 255, 255, 255, 255, 255, 255, 255, 1]+ , tstI [0 :: Int, 2, -2, 127, -128]+ , tstI [0 :: Integer, 2, -2, 127, -128, -256, -512]+ , encRaw (-1024 :: Integer) [255, 15]+ , encRaw (0 :: Float) [0, 0, 0, 0]+ , encRaw (-2 :: Float) [0b11000000, 0, 0, 0]+ , encRaw (0.085 :: Float) [0b00111101, 0b10101110, 0b00010100, 0b01111011]+ , encRaw (0 :: Double) [0, 0, 0, 0, 0, 0, 0, 0]+ , encRaw (-2 :: Double) [0b11000000, 0, 0, 0, 0, 0, 0, 0]+ , encRaw (23 :: Double) [0b01000000, 0b00110111, 0, 0, 0, 0, 0, 0]+ , encRaw (-0.15625 :: Float) [0b10111110, 0b00100000, 0, 0]+ , encRaw (-0.15625 :: Double) [0b10111111, 0b11000100, 0, 0, 0, 0, 0, 0]+ , encRaw+ (-123.2325E-23 :: Double)+ [ 0b10111011+ , 0b10010111+ , 0b01000111+ , 0b00101000+ , 0b01110101+ , 0b01111011+ , 0b01000111+ , 0b10111010]+ , encRaw (Left True :: Either Bool (Double, Double)) [0b01000000]+ , encRaw (-2.1234E15 :: Double) [195, 30, 44, 226, 90, 221, 64, 0]+ , encRaw (1.1234E-22 :: Double) [59, 96, 249, 241, 120, 219, 249, 174]+ , encRaw+ ((False, -2.1234E15) :: (Bool, Double))+ [97, 143, 22, 113, 45, 110, 160, 0, 0]+ , encRaw+ ((True, -2.1234E15) :: (Bool, Double))+ [225, 143, 22, 113, 45, 110, 160, 0, 0]+ , encRaw ((-2.1234E15, 1.1234E-22) :: (Double, Double))+ $ [0b11000011, 30, 44, 226, 90, 221, 64, 0]+ ++ [59, 96, 249, 241, 120, 219, 249, 174]+ , encRaw+ ((True, -2.1234E15, 1.1234E-22) :: (Bool, Double, Double))+ [ 0b11100001+ , 143+ , 22+ , 113+ , 45+ , 110+ , 160+ , 0+ , 29+ , 176+ , 124+ , 248+ , 188+ , 109+ , 252+ , 215+ , 0]+ , encRaw+ (Right (-2.1234E15, 1.1234E-22) :: Either Bool (Double, Double))+ [ 0b11100001+ , 143+ , 22+ , 113+ , 45+ , 110+ , 160+ , 0+ , 29+ , 176+ , 124+ , 248+ , 188+ , 109+ , 252+ , 215+ , 0]+ , encRaw (Left True :: Either Bool Direction) [0b01000000]+ , encRaw (Right West :: Either Bool Direction) [0b11110000]+ , map trip [minBound, maxBound :: Word8]+ , map trip [minBound, maxBound :: Word16]+ , map trip [minBound, maxBound :: Word32]+ , map trip [minBound, maxBound :: Word64]+ , map trip [minBound :: Int8, maxBound :: Int8]+ , map trip [minBound :: Int16, maxBound :: Int16]+ , map trip [minBound :: Int32, maxBound :: Int32]+ , map trip [minBound :: Int64, maxBound :: Int64]+ , map tripShow [0 :: Float, -0 :: Float, 0 / 0 :: Float, 1 / 0 :: Float]+ , map+ tripShow+ [0 :: Double, -0 :: Double, 0 / 0 :: Double, 1 / 0 :: Double]+ , encRaw '\0' [0]+ , encRaw '\1' [1]+ , encRaw '\127' [127]+ , encRaw 'a' [97]+ , encRaw 'à' [224, 1]+ , encRaw '经' [207, 253, 1]+ , [trip [chr 0x10FFFF]]+ , encRaw Unit []+ , encRaw (Un False) [0]+ , encRaw (One, Two, Three) [16 + 8]+ , encRaw (Five, Five, Five) [255, 128]+ --,s (NECons True (Elem True)) [128+64+16]+ , encRaw "" [0]+#ifdef LIST_BIT+ , encRaw "abc" [176, 216, 172, 96]+ , encRaw [False, True, False, True] [128 + 32 + 16 + 8 + 2 + 1, 0]+#elif defined(LIST_BYTE)+ , s "abc" s3+ , s (cs 600) s600+#endif+ -- Aligned structures+ --,s (T.pack "") [1,0]+ --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]+ --,s (T.pack "abc") (al s3)+ --,s (T.pack $ cs 600) (al s600)+ , encRaw map1 [0b10111000]+ , encRaw (B.pack $ csb 3) (bsl c3)+ , encRaw (B.pack $ csb 600) (bsl s600)+ , encRaw (L.pack $ csb 3) (bsl c3)+ -- Long LazyStrings can have internal sections shorter than 255+ --,s (L.pack $ csb 600) (bsl s600)+ , [trip [1 .. 100 :: Int16]]+ -- See https://github.com/typelead/eta/issues/901+#ifndef ETA_VERSION+ , [trip longAsciiStrT]+ , [trip longBoolListT]+#endif+ , [trip asciiTextT]+ , [trip english]+ , [trip "维护和平正"]+ , [trip (T.pack "abc")]+ , [trip unicodeText]+ , [trip unicodeTextUTF8T]+ , [trip chineseTextUTF8T]+#if ! defined (ETA_VERSION)+ , [trip chineseTextUTF16T]+ , [trip unicodeTextUTF16T]+#endif+ , [trip longBS, trip longLBS]+ , [trip longSBS]+ ]+--al = (1:) -- prealign+ where+ bsl = id -- noalign++ tstI = map ti++ ti v+ | v >= 0 = testCase (unwords ["Int", show v])+ $ teq v (2 * fromIntegral v :: Word64)+ | otherwise = testCase (unwords ["Int", show v])+ $ teq v (2 * fromIntegral (-v) - 1 :: Word64)++ teq a b = ser a @?= ser b++ --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]+ -- Aligned values unflat to the original value, modulo the added filler.+ a v e = [ testCase (unwords ["flat", sshow v]) $ ser v @?= e+ , testCase (unwords ["unflat", sshow v])+ $ let Right v' = des e+ in v @?= v']++ -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e+ -- ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']+encRaw :: forall a. (Show a, Flat a) => a -> [Word8] -> [TestTree]+encRaw v e =+ [ testCase (unwords ["flat raw", sshow v, show . B.unpack . flat $ v])+ $ serRaw v @?= e]++trip :: forall a. (Show a, Flat a, Eq a) => a -> TestTree+trip v = testCase (unwords ["roundtrip", sshow v])+ $+ -- direct comparison+ (unflat (flat v :: B.ByteString) :: Decoded a) @?= (Right v :: Decoded a)++tripShow :: forall a. (Show a, Flat a, Eq a) => a -> TestTree+tripShow v = testCase (unwords ["roundtrip", sshow v])+ $+ -- we use show to get Right NaN == Right NaN+ show (unflat (flat v :: B.ByteString) :: Decoded a)+ @?= show (Right v :: Decoded a)++-- Test Data+lzBS = L.pack bs++stBS = B.pack bs++bs = [32, 32, 32 :: Word8]++s3 = [3, 97, 98, 99, 0]++c3a = [3, 99, 99, 99, 0] -- Array Word8++c3 = pre c3a++s600 = pre s600a++pre = (1:)++s600a = concat [[255], csb 255, [255], csb 255, [90], csb 90, [0]]++s600B =+ concat [[55], csb 55, [255], csb 255, [90], csb 90, [200], csb 200, [0]]++longSeq :: Seq.Seq Word8+longSeq = Seq.fromList lbs++longBS = B.pack lbs++longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]++lbs = concat $ replicate 100 [234, 123, 255, 0]++cs n = replicate n 'c' -- take n $ cycle ['a'..'z']++csb = map (fromIntegral . ord) . cs++map1 = C.fromList [(False, True), (True, False)]++ns :: [(Word64, Int)]+ns = [((-) (2 ^ (i * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]++nsI :: [(Int64, Int)]+nsI = nsI_++nsII :: [(Integer, Int)]+nsII = nsI_++nsI_ = [((-) (2 ^ (((-) i 1) * 7)) 1, fromIntegral (8 * i)) | i <- [1 .. 10]]++shBS = SBS.toShort stBS++longSBS = SBS.toShort longBS++sshow = take 80 . show++showB = show . B.unpack++errDec :: forall a. (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree]++--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""]+errDec _ bs = [ testCase "bad decode"+ $ let ev = (des bs :: Decoded a)+ in isRight ev @?= False]++ser :: Flat a => a -> [Word8]+ser = B.unpack . flat++des :: Flat a => [Word8] -> Decoded a+des = unflat++flatRawWith sz enc = B.unpack+ $ E.strictEncoder (sz + 8) (E.Encoding $ enc >=> E.eFillerF)++serRaw :: Flat a => a -> [Word8]++-- serRaw = B.unpack . flatRaw+-- serRaw = L.unpack . flatRaw+serRaw = asBytes . bits++--desRaw :: Flat a => [Word8] -> Decoded a+--desRaw = unflatRaw . L.pack+type RT a = a -> Bool++type RTL a = Large a -> Bool++prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool+prop_Flat_roundtrip = roundTripExt++prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool+prop_Flat_Large_roundtrip (Large x) = roundTripExt x++roundTrip x = unflat (flat x :: B.ByteString) == Right x++-- Test roundtrip for both the value and the value embedded between bools+roundTripExt x = roundTrip x && roundTrip (True, x, False)++prop_double_conv d = wordToDouble (doubleToWord d) == d++prop_float_conv d = wordToFloat (floatToWord d) == d+{-+prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool+prop_common_unsigned n _ = let n2 :: h = fromIntegral n+ in flat n == flat n2+-}+-- e :: Stream Bool+-- e = unflatIncremental . flat $ stream1+-- el :: List Bool+-- el = unflatIncremental . flat $ infList+-- deflat = unflat+-- b1 :: BLOB UTF8+-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))+-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))
test/Test/Data.hs view
@@ -1,43 +1,51 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ {- A collection of data types used for testing. -}- module Test.Data where import Data.Data import Data.Int import Data.Word import GHC.Generics-import qualified Test.Data2 as D2--- import Test.Tasty.QuickCheck+import qualified Test.Data2 as D2 -data Void deriving Generic+-- import Test.Tasty.QuickCheck+data Void+ deriving Generic -data X = X X deriving Generic+data X = X X+ deriving Generic -data Unit = Unit deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Unit = Unit+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Un = Un {un::Bool} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Un = Un { un :: Bool }+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data D2 = D2 Bool N deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data D2 = D2 Bool N+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data D4 = D4 Bool N Unit N3 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data D4 = D4 Bool N Unit N3+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Enumeration-data N3 = N1 | N2 | N3- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Enum)+data N3 = N1+ | N2+ | N3+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum) data N = One | Two@@ -47,10 +55,8 @@ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Enum, Bounded) -- toForestD :: Forest a -> ForestD (Tr2 a)- -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt))- -- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt))-+-- toForestD (Forest lt) = undefined -- Forest2 (ForestD (map (\t -> let Tr2 tt = treeConv t in tt) . toList $ lt)) toForest2 :: Forest a -> Forest2 a toForest2 (Forest f) = Forest2 (ForestD $ fmap toTr f) @@ -61,80 +67,114 @@ toTr2 (Tr a (Forest f)) = Tr2 (TrD a (ForestD $ fmap toTr2 f)) -- tying the recursive knot, equivalent to Forest/Tree-data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Forest2 a = Forest2 (ForestD (TrD (Forest2 a) a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Tr2 a = Tr2 (TrD (ForestD (Tr2 a)) a)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- First-order non mutually recursive-data ForestD t = ForestD (List t) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data TrD f a = TrD a f deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data ForestD t = ForestD (List t)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data TrD f a = TrD a f+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- Explicit mutually recursive-data Forest a = Forest (List (Tr a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data Tr a = Tr a (Forest a) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Forest a = Forest (List (Tr a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Tr a = Tr a (Forest a)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ data Words = Words Word8 Word16 Word32 Word64- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data Ints = Ints Int8 Int16 Int32 Int64- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- non-recursive data type data Various = V1 (Maybe Bool)- -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N)+ -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N) | V2 Bool (Either Bool (Maybe Bool)) | VF Float Double Double | VW Word Word8 Word16 Word32 Word64 | VI Int Int8 Int16 Int32 Int64 | VII Integer Integer Integer- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Phantom type-data Phantom a = Phantom deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-+data Phantom a = Phantom+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- Recursive data types--data RR a b c = RN {rna::a, rnb::b ,rnc::c}+data RR a b c = RN { rna :: a, rnb :: b, rnc :: c } | RA a (RR a a c) b | RAB a (RR c b a) b deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Expr = ValB Bool | Or Expr Expr | If Expr Expr Expr deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Expr = ValB Bool+ | Or Expr Expr+ | If Expr Expr Expr+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data List a = C a (List a) | N- deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic ,Generic1,Functor,Foldable)+ deriving (Eq, Ord, Read, Show, Typeable, Traversable, Data, Generic, Generic1+ , Functor, Foldable) -data ListS a = Nil | Cons a (ListS a)- deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data, Generic ,Generic1)+data ListS a = Nil+ | Cons a (ListS a)+ deriving (Eq, Ord, Read, Show, Typeable, Functor, Foldable, Traversable, Data+ , Generic, Generic1) -- non-regular Haskell datatypes like: -- Binary instances but no Model-data Nest a = NilN | ConsN (a, Nest (a, a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Nest a = NilN+ | ConsN (a, Nest (a, a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data TN a = LeafT a | BranchT (TN (a,a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data TN a = LeafT a+ | BranchT (TN (a, a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Bush a = NilB | ConsB (a, Bush (Bush a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Bush a = NilB+ | ConsB (a, Bush (Bush a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- Perfectly balanced binary tree-data Perfect a = ZeroP a | SuccP (Perfect (Fork a)) deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data Fork a = Fork a a deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Perfect a = ZeroP a+ | SuccP (Perfect (Fork a))+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data Fork a = Fork a a+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- non regular with higher-order kind parameters -- no Binary/Model instances-data PerfectF f α = NilP | ConsP α (PerfectF f (f α)) deriving (Typeable,Generic) -- No Data+data PerfectF f α = NilP+ | ConsP α (PerfectF f (f α))+ deriving (Typeable, Generic) -- No Data data Pr f g a = Pr (f a (g a)) -data Higher f a = Higher (f a) deriving (Typeable,Generic,Data)+data Higher f a = Higher (f a)+ deriving (Typeable, Generic, Data) -- data Pr2 (f :: * -> *) a = Pr2 (f )--data Free f a = Pure a | Roll (f (Free f a)) deriving (Typeable,Generic)+data Free f a = Pure a+ | Roll (f (Free f a))+ deriving (Typeable, Generic) -- mutual references-data A = A B | AA Int deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data B = B A | BB Char deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data A = A B+ | AA Int+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +data B = B A+ | BB Char+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- recursive sets: -- Prob: ghc will just explode on this -- data MM1 = MM1 MM2 MM4 MM0 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)@@ -144,66 +184,92 @@ -- data MM4 = MM4 MM4 MM2 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- data MM5 = MM5 Unit MM6 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -- data MM6 = MM6 MM5 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)- data A0 = A0 B0 B0 D0 Bool | A1 (List Bool) (List Unit) (D2.List Bool) (D2.List Bool)- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data B0 = B0 C0 | B1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data C0 = C0 A0 | C1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data D0 = D0 E0 | D1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)-data E0 = E0 D0 | E1 deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Even = Zero | SuccE Odd+data B0 = B0 C0+ | B1+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data C0 = C0 A0+ | C1+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data D0 = D0 E0+ | D1+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data E0 = E0 D0+ | E1+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Even = Zero+ | SuccE Odd+ data Odd = SuccO Even -- Existential types -- data Fold a b = forall x. Fold (x -> a -> x) x (x -> b)- -- data Some :: (* -> *) -> * where -- Some :: f a -> Some f- -- data Dict (c :: Constraint) where -- Dict :: c => Dict c-data Direction = North | South | Center | East | West- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Direction = North+ | South+ | Center+ | East+ | West+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) data Stream a = Stream a (Stream a)- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Functor,Foldable,Traversable)+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Functor, Foldable+ , Traversable) -data Tree a = Node (Tree a) (Tree a) | Leaf a- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable)+data Tree a = Node (Tree a) (Tree a)+ | Leaf a+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable) -- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html-data Car = Car {- serialNumber::Word64- ,modelYear::Word16- ,available::Bool- ,code::CarModel- ,someNumbers::[Int32]- ,vehicleCode::String- ,extras::[OptionalExtra]- ,engine::Engine- ,fuelFigures::[Consumption]- ,performanceFigures :: [(OctaneRating,[Acceleration])]- ,make::String- ,carModel::String- } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Car =+ Car { serialNumber :: Word64+ , modelYear :: Word16+ , available :: Bool+ , code :: CarModel+ , someNumbers :: [Int32]+ , vehicleCode :: String+ , extras :: [OptionalExtra]+ , engine :: Engine+ , fuelFigures :: [Consumption]+ , performanceFigures :: [(OctaneRating, [Acceleration])]+ , make :: String+ , carModel :: String+ }+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Acceleration = Acceleration {mph::Word16,seconds::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Acceleration = Acceleration { mph :: Word16, seconds :: Float }+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) type OctaneRating = Word8 -- minValue="90" maxValue="110" -data Consumption = Consumption {cSpeed::Word16,cMpg::Float} deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Consumption = Consumption { cSpeed :: Word16, cMpg :: Float }+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data CarModel = ModelA | ModelB | ModelC deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data CarModel = ModelA+ | ModelB+ | ModelC+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data OptionalExtra = SunRoof | SportsPack | CruiseControl deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data OptionalExtra = SunRoof+ | SportsPack+ | CruiseControl+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -data Engine = Engine {- capacity :: Word16- ,numCylinders:: Word8- ,maxRpm:: Word16 -- constant 9000- ,manufacturerCode :: String- ,fuel::String -- constant Petrol- } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+data Engine = Engine { capacity :: Word16+ , numCylinders :: Word8+ , maxRpm :: Word16 -- constant 9000+ , manufacturerCode :: String+ , fuel :: String -- constant Petrol+ }+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
test/Test/Data/Arbitrary.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}--- {-# LANGUAGE TemplateHaskell , CPP#-}+{-# LANGUAGE CPP , ScopedTypeVariables #-} module Test.Data.Arbitrary where import qualified Data.ByteString as BS@@ -11,11 +10,21 @@ import Test.Data -- import Data.DeriveTH +-- #if MIN_VERSION_base(4,9,0)+import qualified Data.List.NonEmpty as BI+-- #endif+ import Numeric.Natural (Natural) +#if MIN_VERSION_base(4,8,0) && MIN_VERSION_QuickCheck(2,10,0)+instance Arbitrary a => Arbitrary (BI.NonEmpty a) where+ arbitrary = BI.fromList . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList a))+ shrink xs = BI.fromList <$> shrink (BI.toList xs)+ instance Arbitrary Natural where arbitrary = arbitrarySizedNatural shrink = shrinkIntegral+#endif -- Copied from quickcheck-instances (not used directly as it requires old-time that is incompatible with ghcjs) @@ -31,13 +40,13 @@ arbitrary = SBS.pack <$> arbitrary shrink xs = SBS.pack <$> shrink (SBS.unpack xs) -instance Arbitrary TS.Text where- arbitrary = TS.pack <$> arbitrary- shrink xs = TS.pack <$> shrink (TS.unpack xs)+-- instance Arbitrary TS.Text where+-- arbitrary = TS.pack <$> arbitrary+-- shrink xs = TS.pack <$> shrink (TS.unpack xs) -instance Arbitrary TL.Text where- arbitrary = TL.pack <$> arbitrary- shrink xs = TL.pack <$> shrink (TL.unpack xs)+-- instance Arbitrary TL.Text where+-- arbitrary = TL.pack <$> arbitrary+-- shrink xs = TL.pack <$> shrink (TL.unpack xs) -- xxx = generate (arbitrary :: Gen (Large (Int))) @@ -58,6 +67,7 @@ -- instance Arbitrary Word7 where arbitrary = toEnum <$> choose (0, 127) -- derive makeArbitrary ''ASCII -- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta)+ -- , run in the project directory: derive -a test/Test/Data.hs --derive=Arbitrary {-! deriving instance Arbitrary N
test/Test/Data/Flat.hs view
@@ -1,18 +1,20 @@+{-# LANGUAGE UndecidableInstances, DeriveGeneric+ , FlexibleContexts, FlexibleInstances, StandaloneDeriving , CPP #-} -{-# LANGUAGE UndecidableInstances ,DeriveGeneric, FlexibleContexts, FlexibleInstances,StandaloneDeriving #-} module Test.Data.Flat ( module Test.Data ) where-import Data.Flat-import Data.Flat.Encoder-import Data.Flat.Decoder++import Flat+-- import Flat.Encoder+-- import Flat.Decoder import Test.Data import Test.Data2.Flat ( )-import Data.Word-import Data.Foldable-import Data.Int-import GHC.Generics+-- import Data.Word+-- import Data.Foldable+-- import Data.Int+-- import GHC.Generics {- Compilation times:@@ -24,20 +26,39 @@ | 8.0.2 | NO | 4:18 | | 8.0.2 | YES | 4:18 | -}- -- GHC 8.0.2 chokes on this -- instance Flat A0 -- instance Flat B0 -- instance Flat C0 -- instance Flat D0 -- instance Flat E0+#if MIN_VERSION_base(4,9,0) && ! MIN_VERSION_base(4,16,0)+deriving instance Generic (a, b, c, d, e, f, g, h) -deriving instance Generic (a,b,c,d,e,f,g,h)-deriving instance Generic (a,b,c,d,e,f,g,h,i)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h) => Flat (a,b,c,d,e,f,g,h)-instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f, Flat g,Flat h,Flat i) => Flat (a,b,c,d,e,f,g,h,i)+deriving instance Generic (a, b, c, d, e, f, g, h, i)+#endif +instance {-# OVERLAPPABLE #-}( Flat a+ , Flat b+ , Flat c+ , Flat d+ , Flat e+ , Flat f+ , Flat g+ , Flat h) => Flat (a, b, c, d, e, f, g, h)++instance {-# OVERLAPPABLE #-}( Flat a+ , Flat b+ , Flat c+ , Flat d+ , Flat e+ , Flat f+ , Flat g+ , Flat h+ , Flat i) => Flat (a, b, c, d, e, f, g, h, i)+ instance Flat N+ instance Flat Unit instance Flat a => Flat (List a)@@ -45,38 +66,40 @@ instance Flat a => Flat (Tree a) instance Flat Direction+ instance Flat Words+ instance Flat Ints+ instance Flat Void instance Flat N3+ instance Flat Un instance Flat a => Flat (ListS a) instance Flat A+ instance Flat B instance Flat D2+ instance Flat D4 instance Flat a => Flat (Phantom a) -- Slow to compile instance Flat Various- -- Custom instances -- instance {-# OVERLAPPING #-} Flat (Tree (N,N,N)) --where -- size (Node t1 t2) = 1 + size t1 + size t2 -- size (Leaf a) = 1 + size a- -- -57% -- instance {-# OVERLAPPING #-} Flat [N] -- where size = foldl' (\s n -> s + 1 + size n) 1- -- instance {-# OVERLAPPING #-} Flat (N,N,N) -- where- -- {-# INLINE size #-}- -- size (n1,n2,n3) = size n1 + size n2 + size n3-+-- {-# INLINE size #-}+-- size (n1,n2,n3) = size n1 + size n2 + size n3 -- -50% -- instance {-# OVERLAPPING #-} Flat (N,N,N) where -- {-# INLINE encode #-}@@ -88,22 +111,14 @@ -- Three -> eBitsF 2 2 -- Four -> eBitsF 3 6 -- Five -> eBitsF 3 7-- -- instance (Flat a, Flat b, Flat c) => Flat (RR a b c) -- instance Flat a => Flat (Perfect a) -- instance Flat a => Flat (Fork a) -- instance Flat a => Flat (Nest a) --instance Flat a => Flat (Stream a) where decode = Stream <$> decode <*> decode -- instance Flat Expr--- --instance (Flat a,Flat (f a),Flat (f (f a))) => Flat (PerfectF f a)-- -- instance Flat a => Flat (Stream a)- {- | |@@ -114,11 +129,9 @@ -- instance {-# OVERLAPPABLE #-} Flat a => Flat (Tree a) where -- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 -- encode (Leaf a) = eTrue <> encode a- -- instance {-# OVERLAPPING #-} Flat (Tree N) where -- encode (Node t1 t2) = eFalse <> encode t1 <> encode t2 -- encode (Leaf a) = eTrue <> encode a- -- -- -34% (why?) -- instance Flat N where -- {-# INLINE encode #-}@@ -128,62 +141,54 @@ -- Three -> eBits 2 2 -- Four -> eBits 3 6 -- Five -> eBits 3 7- -- instance {-# OVERLAPPING #-} Flat (Tree N)- -- where- -- {-# INLINE decode #-}- -- decode = do- -- tag <- dBool- -- if tag- -- then Leaf <$> decode- -- else Node <$> decode <*> decode-+-- where+-- {-# INLINE decode #-}+-- decode = do+-- tag <- dBool+-- if tag+-- then Leaf <$> decode+-- else Node <$> decode <*> decode -- instance Flat N- -- where- -- {-# INLINE decode #-}- -- decode = do- -- tag <- dBool- -- if tag- -- then do- -- tag <- dBool- -- if tag- -- then do- -- tag <- dBool- -- if tag- -- then return Five- -- else return Four- -- else return Three- -- else do- -- tag <- dBool- -- if tag- -- then return Two- -- else return One-- -- {-# INLINE size #-}- -- size n s = s + case n of- -- One -> 2 - -- Two -> 2- -- Three -> 2- -- Four -> 3- -- Five -> 3-+-- where+-- {-# INLINE decode #-}+-- decode = do+-- tag <- dBool+-- if tag+-- then do+-- tag <- dBool+-- if tag+-- then do+-- tag <- dBool+-- if tag+-- then return Five+-- else return Four+-- else return Three+-- else do+-- tag <- dBool+-- if tag+-- then return Two+-- else return One+-- {-# INLINE size #-}+-- size n s = s + case n of+-- One -> 2 +-- Two -> 2+-- Three -> 2+-- Four -> 3+-- Five -> 3 -- instance Flat N where -- instance {-# OVERLAPPING #-} Flat (Tree N) -- where- -- -- {-# INLINE encode #-} -- encode (Node t1 t2) = Writer $ \s -> do -- !s1 <- runWriter eFalse s -- !s2 <- runWriter (encode t1) s1 -- s3 <- runWriter (encode t2) s2 -- return s3-- -- encode (Leaf a) = Writer $ \s -> do- -- s1 <- runWriter eTrue s- -- runWriter (encode a) s1-+-- encode (Leaf a) = Writer $ \s -> do+-- s1 <- runWriter eTrue s+-- runWriter (encode a) s1 -- size (Node t1 t2) = 1 + size t1 + size t2 -- size (Leaf a) = 1 + size a- --instance Flat N
test/Test/Data/Values.hs view
@@ -1,6 +1,8 @@+ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE NoMonomorphismRestriction , ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-} module Test.Data.Values where import Control.DeepSeq@@ -9,20 +11,21 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short.Internal as SBS import Data.Char-import Data.Flat import Data.Foldable import Data.Int-import Data.List+import qualified Data.IntMap as IM+import Flat+-- import qualified Data.IntSet as IS+-- import Data.List import qualified Data.Map as M import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Word import Test.Data import qualified Test.Data2 as D2-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS -- import Data.Array as A + instance NFData Various instance NFData a => NFData (List a) instance NFData a => NFData (D2.List a)@@ -74,7 +77,8 @@ s1 = "a" s2 = "中文版本" s3 = ['A'..'z']-s4 = Prelude.concatMap show [1..400]+s4 :: [Char]+s4 = Prelude.concatMap show [1::Int ..400] t1 = T.pack s1 t2 = T.pack s2@@ -94,10 +98,10 @@ l1 = l2L $ take 11 [11::Word8,22..33] lBool :: List Bool-lBool = l2L $ map odd [1..99]+lBool = l2L $ map odd [1::Int ..99] lBool2 :: List Bool-lBool2 = l2L $ map odd [1..1000]+lBool2 = l2L $ map odd [1::Int ..1000] lBool0 = C False (C True (C True (C False (C False (C False (C True (C False (C True (C False (C True (C True (C False (C False (C False N)))))))))))))) @@ -155,7 +159,7 @@ treeN33Large :: Tree ((N,N,N),(N,N,N),(N,N,N)) treeN33Large = mkTree asN33 largeSize -treeVarious = mkTree (const v2) 100+treeVarious = mkTree (const v2) (100::Int) mkTreeOf :: forall a. (Enum a ,Bounded a)=> Int -> Tree a mkTreeOf = let l = fromEnum (maxBound :: a) +1@@ -181,11 +185,23 @@ treeN = mkTree asN3 1 -asciiStrT = ("asciiStr", longS $ "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces a tricky decision at today's FOMC meeting. Photograph: Action Press/Rex. Theme park operator Merlin Entertainments suffered a significant drop in visitor numbers to its Alton Towers attraction after a serious rollercoaster accident in June.")+longAsciiStrT = ("asciiStr", longS english ) +asciiTextT = ("asciiText", T.pack $ longS english )+ unicodeTextUTF8T = ("unicodeTextUTF8",UTF8Text unicodeText)++chineseTextUTF8T = ("chineseTextUTF8",UTF8Text chineseText)++#if ! defined (ETA_VERSION) unicodeTextUTF16T = ("unicodeTextUTF16",UTF16Text unicodeText)+chineseTextUTF16T = ("chineseTextUTF16",UTF16Text chineseText)+#endif +-- chineseTextT = ("chineseText",chinesText)+chineseText = T.pack $ longS chinese++ unicodeTextT = ("unicodeText",unicodeText) unicodeText = T.pack unicodeStr @@ -193,12 +209,23 @@ unicodeStr = notLongS uniSS -uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响" +-- uniSS = "\x1F600\&\x1F600\&\x1F600\&I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1].维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响"+uniSS = concat [special,latin,chinese]+special = "∀\&"+-- Crashes eta+-- emoji = "\x1F600"++english = "To hike, or not to hike? US Federal Reserve chair Janet Yellen faces a tricky decision at today's FOMC meeting. Photograph: Action Press/Rex. Theme park operator Merlin Entertainments suffered a significant drop in visitor numbers to its Alton Towers attraction after a serious rollercoaster accident in June."+latin = "I promessi sposi è un celebre romanzo storico di Alessandro Manzoni, ritenuto il più famoso e il più letto tra quelli scritti in lingua italiana[1]."+chinese = "维护和平正义 开创美好未来——习近平主席在纪念中国人民抗日战争暨世界反法西斯战争胜利70周年大会上重要讲话在国际社会引起热烈反响"+ longS = take 1000000 . concat . repeat notLongS = take 1000 . concat . repeat +longBoolListT = ("Long [Bool]",map (odd . ord) (longS uniSS) :: [Bool])+ arr0 = ("[Bool]",map (odd . ord) unicodeStr :: [Bool]) arr1 = ("[Word]",map (fromIntegral . ord) unicodeStr :: [Word])@@ -303,7 +330,9 @@ , NF arr0 , NF longS , NF unicodeStr- , NF asciiStrT+ , NF longBoolListT+ , NF longAsciiStrT+ , NF asciiTextT , NF unicodeStrT , NF unicodeTextT --, NF unicodeTextUTF8T
test/Test/Data2/Flat.hs view
@@ -1,5 +1,5 @@ module Test.Data2.Flat(module Test.Data2) where-import Data.Flat+import Flat import Test.Data2 instance Flat a => Flat (List a)
test/Test/E.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass ,CPP #-} module Test.E where -import Data.Flat+import Flat import Data.List import Control.DeepSeq -- import Data.Proxy
test/Test/E/Flat.hs view
@@ -3,12 +3,12 @@ {-# LANGUAGE StandaloneDeriving #-} module Test.E.Flat() where -import Data.Flat-import Data.Flat.Decoder-import Data.Flat.Encoder+import Flat+import Flat.Decoder()+import Flat.Encoder() import Test.E -t = putStrLn $ gen 4+-- t = putStrLn $ gen 4 -- Test only, incorrect instances -- Not faster than generated ones (at least up to E16)